From 105c3177000865ad953317e0d63f7398d4138529 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Wed, 18 Feb 2009 03:14:31 +0900 Subject: [PATCH 001/154] initial import --- sexp-huff.c | 128 +++++ sexp-hufftabs.c | 92 +++ sexp-orig.c | 594 +++++++++++++++++++ sexp-unhuff.c | 71 +++ sexp.c | 1457 +++++++++++++++++++++++++++++++++++++++++++++++ 5 files changed, 2342 insertions(+) create mode 100644 sexp-huff.c create mode 100644 sexp-hufftabs.c create mode 100644 sexp-orig.c create mode 100644 sexp-unhuff.c create mode 100644 sexp.c diff --git a/sexp-huff.c b/sexp-huff.c new file mode 100644 index 00000000..abf6bc9f --- /dev/null +++ b/sexp-huff.c @@ -0,0 +1,128 @@ + {12, 0x0C00}, /* '\x00' */ + {15, 0x0000}, /* '\x01' */ + {15, 0x4000}, /* '\x02' */ + {15, 0x2000}, /* '\x03' */ + {15, 0x6000}, /* '\x04' */ + {15, 0x0800}, /* '\x05' */ + {15, 0x4800}, /* '\x06' */ + {15, 0x2800}, /* '\x07' */ + {15, 0x6800}, /* '\x08' */ + {15, 0x1800}, /* '\x09' */ + {15, 0x5800}, /* '\x0a' */ + {15, 0x3800}, /* '\x0b' */ + {15, 0x7800}, /* '\x0c' */ + {15, 0x0100}, /* '\x0d' */ + {15, 0x4100}, /* '\x0e' */ + {15, 0x2100}, /* '\x0f' */ + {15, 0x6100}, /* '\x10' */ + {15, 0x1100}, /* '\x11' */ + {15, 0x5100}, /* '\x12' */ + {15, 0x3100}, /* '\x13' */ + {15, 0x7100}, /* '\x14' */ + {15, 0x0900}, /* '\x15' */ + {15, 0x4900}, /* '\x16' */ + {15, 0x2900}, /* '\x17' */ + {15, 0x6900}, /* '\x18' */ + {15, 0x1900}, /* '\x19' */ + {15, 0x5900}, /* '\x1a' */ + {15, 0x3900}, /* '\x1b' */ + {15, 0x7900}, /* '\x1c' */ + {15, 0x0500}, /* '\x1d' */ + {15, 0x4500}, /* '\x1e' */ + {15, 0x2500}, /* '\x1f' */ + {15, 0x6500}, /* '\x20' */ + { 8, 0x0040}, /* '!' */ + {15, 0x1500}, /* '"' */ + {15, 0x5500}, /* '#' */ + {15, 0x3500}, /* '$' */ + {15, 0x7500}, /* '%' */ + {15, 0x0D00}, /* '&' */ + {15, 0x4D00}, /* '\'' */ + {15, 0x2D00}, /* '(' */ + {15, 0x6D00}, /* ')' */ + {11, 0x0300}, /* '*' */ + {10, 0x0180}, /* '+' */ + {15, 0x1D00}, /* ',' */ + { 4, 0x000D}, /* '-' */ + {15, 0x5D00}, /* '.' */ + {10, 0x0380}, /* '/' */ + {15, 0x3D00}, /* '0' */ + {15, 0x7D00}, /* '1' */ + {14, 0x0080}, /* '2' */ + {14, 0x2080}, /* '3' */ + {14, 0x1080}, /* '4' */ + {14, 0x3080}, /* '5' */ + {14, 0x0880}, /* '6' */ + {14, 0x2880}, /* '7' */ + {14, 0x1880}, /* '8' */ + {14, 0x3880}, /* '9' */ + {14, 0x0480}, /* ':' */ + {14, 0x2480}, /* ';' */ + { 7, 0x0050}, /* '<' */ + { 7, 0x0042}, /* '=' */ + { 7, 0x0022}, /* '>' */ + { 5, 0x0009}, /* '?' */ + {14, 0x1480}, /* '@' */ + {14, 0x3480}, /* 'A' */ + {14, 0x0C80}, /* 'B' */ + {14, 0x2C80}, /* 'C' */ + {14, 0x1C80}, /* 'D' */ + {14, 0x3C80}, /* 'E' */ + {14, 0x0280}, /* 'F' */ + {14, 0x2280}, /* 'G' */ + {14, 0x1280}, /* 'H' */ + {14, 0x3280}, /* 'I' */ + {14, 0x0A80}, /* 'J' */ + {14, 0x2A80}, /* 'K' */ + {14, 0x1A80}, /* 'L' */ + {14, 0x3A80}, /* 'M' */ + {14, 0x0680}, /* 'N' */ + {14, 0x2680}, /* 'O' */ + {14, 0x1680}, /* 'P' */ + {14, 0x3680}, /* 'Q' */ + {14, 0x0E80}, /* 'R' */ + {14, 0x2E80}, /* 'S' */ + {14, 0x1E80}, /* 'T' */ + {14, 0x3E80}, /* 'U' */ + {14, 0x0200}, /* 'V' */ + {14, 0x2200}, /* 'W' */ + {14, 0x1200}, /* 'X' */ + {14, 0x3200}, /* 'Y' */ + {14, 0x0A00}, /* 'Z' */ + {14, 0x2A00}, /* '[' */ + {14, 0x1A00}, /* '\\' */ + {14, 0x3A00}, /* ']' */ + {14, 0x0600}, /* '^' */ + {14, 0x2600}, /* '_' */ + {14, 0x1600}, /* '`' */ + { 3, 0x0007}, /* 'a' */ + { 7, 0x0020}, /* 'b' */ + { 4, 0x0004}, /* 'c' */ + { 5, 0x001A}, /* 'd' */ + { 4, 0x0006}, /* 'e' */ + { 7, 0x0002}, /* 'f' */ + { 5, 0x0011}, /* 'g' */ + { 6, 0x0012}, /* 'h' */ + { 4, 0x000C}, /* 'i' */ + {12, 0x0400}, /* 'j' */ + { 8, 0x00C0}, /* 'k' */ + { 5, 0x0018}, /* 'l' */ + { 6, 0x0032}, /* 'm' */ + { 4, 0x0005}, /* 'n' */ + { 5, 0x000A}, /* 'o' */ + { 5, 0x0001}, /* 'p' */ + { 7, 0x0070}, /* 'q' */ + { 3, 0x0003}, /* 'r' */ + { 5, 0x0008}, /* 's' */ + { 4, 0x000E}, /* 't' */ + { 5, 0x0019}, /* 'u' */ + { 7, 0x0062}, /* 'v' */ + { 7, 0x0030}, /* 'w' */ + { 7, 0x0060}, /* 'x' */ + { 7, 0x0010}, /* 'y' */ + {11, 0x0700}, /* 'z' */ + {14, 0x3600}, /* '{' */ + {14, 0x0E00}, /* '|' */ + {14, 0x2E00}, /* '}' */ + {14, 0x1E00}, /* '~' */ + {14, 0x3E00}, /* '\x7f' */ diff --git a/sexp-hufftabs.c b/sexp-hufftabs.c new file mode 100644 index 00000000..7704184f --- /dev/null +++ b/sexp-hufftabs.c @@ -0,0 +1,92 @@ +/* auto-generated by ./symhuff.scm on Sun Feb 25 23:12:52 2007 */ + +char _huff_tab21[] = { + '\x01', '\x00', '\x03', '\x00', '\x02', '\x00', '\x04', '\x00', +}; + +char _huff_tab19[] = { + '\x01', 'j', '\x01', '\x00', +}; + +char _huff_tab20[] = { + '\x05', '\x09', '\x07', '\x0b', '\x06', '\x0a', '\x08', '\x0c', +}; + +char _huff_tab18[] = { + '2', ':', '6', 'B', '4', '@', '8', 'D', + '3', ';', '7', 'C', '5', 'A', '9', 'E', +}; + +char _huff_tab17[] = { + '\x0d', '\x1d', '\x15', '&', '\x11', '"', '\x19', ',', + '\x0f', '\x1f', '\x17', '(', '\x13', '$', '\x1b', '0', + '\x0e', '\x1e', '\x16', '\'', '\x12', '#', '\x1a', '.', + '\x10', '\x20', '\x18', ')', '\x14', '%', '\x1c', '1', +}; + +char _huff_tab16[] = { + 'V', '^', 'Z', '|', 'X', '`', '\\', '~', + 'W', '_', '[', '}', 'Y', '{', ']', '\x7f', +}; + +char _huff_tab15[] = { + 'F', 'N', 'J', 'R', 'H', 'P', 'L', 'T', + 'G', 'O', 'K', 'S', 'I', 'Q', 'M', 'U', +}; + +char _huff_tab13[] = { + '\x00', '\x00', '\x00', '+', '\x00', '\x00', '\x00', '/', +}; + +char _huff_tab14[] = { + '*', 'z', +}; + +char _huff_tab11[] = { + '\x00', 'b', '\x00', 'x', +}; + +char _huff_tab12[] = { + '!', 'k', +}; + +char _huff_tab9[] = { + '\x00', 's', '\x00', 'l', +}; + +char _huff_tab10[] = { + 'y', 'w', '<', 'q', +}; + +char _huff_tab8[] = { + 'p', '?', 'g', 'u', +}; + +char _huff_tab7[] = { + 'f', '>', '=', 'v', +}; + +char _huff_tab5[] = { + '\x00', 'o', '\x00', 'd', +}; + +char _huff_tab6[] = { + 'h', 'm', +}; + +char _huff_tab4[] = { + 'c', 'i', +}; + +char _huff_tab3[] = { + 'n', '-', +}; + +char _huff_tab1[] = { + '\x00', '\x00', '\x00', 'r', '\x00', '\x00', '\x00', 'a', +}; + +char _huff_tab2[] = { + 'e', 't', +}; + diff --git a/sexp-orig.c b/sexp-orig.c new file mode 100644 index 00000000..1da4500a --- /dev/null +++ b/sexp-orig.c @@ -0,0 +1,594 @@ + +/* #include */ +#include +#include +#include +#include + +/* simple tagging + * ends in 00: pointer + * 1: fixnum + * 010: symbol + * 0110: char + * 1110: other immediate object (NULL, TRUE, FALSE) + */ + +enum sexp_tags { + SEXP_PAIR, + SEXP_SYMBOL, + SEXP_STRING, + SEXP_VECTOR, +}; + +/* would need a proper header for GC */ +typedef struct sexp_struct { + char tag; + void *data1; + void *data2; +} *sexp; + +#define MAKE_IMMEDIATE(n) ((sexp) ((n<<3) + 6)) +#define SEXP_NULL MAKE_IMMEDIATE(0) +#define SEXP_FALSE MAKE_IMMEDIATE(1) +#define SEXP_TRUE MAKE_IMMEDIATE(2) +#define SEXP_EOF MAKE_IMMEDIATE(3) +#define SEXP_UNDEF MAKE_IMMEDIATE(4) +#define SEXP_CLOSE MAKE_IMMEDIATE(5) /* internal use */ +#define SEXP_ERROR MAKE_IMMEDIATE(6) + +#define SEXP_NULLP(x) ((x) == SEXP_NULL) +#define SEXP_POINTERP(x) (((int) x & 3) == 0) +#define SEXP_INTEGERP(x) (((int) x & 3) == 1) +#define SEXP_CHARP(x) (((int) x & 7) == 2) + +#define SEXP_PAIRP(x) (SEXP_POINTERP(x) && (x)->tag == SEXP_PAIR) +#define SEXP_SYMBOLP(x) (SEXP_POINTERP(x) && (x)->tag == SEXP_SYMBOL) +#define SEXP_STRINGP(x) (SEXP_POINTERP(x) && (x)->tag == SEXP_STRING) + +#define SEXP_ALLOC(size) (malloc(size)) +#define SEXP_FREE free +#define SEXP_NEW() ((sexp) SEXP_ALLOC(sizeof(sexp))) + +#define make_integer(n) ((sexp) (((int) n<<2) + 1)) +#define unbox_integer(n) ((int) n>>2) +#define make_character(n) ((sexp) (((int) n<<3) + 2)) +#define unbox_character(n) ((int) n>>3) + +#define vector_length(x) ((int) x->data1) +#define vector_data(x) ((sexp*) x->data2) + +#define string_length(x) ((int) x->data1) +#define string_data(x) ((char*) x->data2) + +sexp cons(sexp head, sexp tail) { + sexp pair = SEXP_NEW(); + if (! pair) return SEXP_ERROR; + pair->tag = SEXP_PAIR; + pair->data1 = (void*) head; + pair->data2 = (void*) tail; + return pair; +} + +sexp car(sexp obj) { + return (SEXP_PAIRP(obj)) ? obj->data1 : SEXP_ERROR; +} + +sexp cdr(sexp obj) { + return (SEXP_PAIRP(obj)) ? obj->data2 : SEXP_ERROR; +} + +sexp set_car(sexp obj, sexp val) { + if (SEXP_PAIRP(obj)) { + return obj->data1 = val; + } else { + return SEXP_ERROR; + } +} + +sexp set_cdr(sexp obj, sexp val) { + if (SEXP_PAIRP(obj)) { + return obj->data2 = val; + } else { + return SEXP_ERROR; + } +} + +sexp nreverse(sexp ls) { + sexp a; + sexp b; + sexp tmp; + + if (ls == SEXP_NULL) { + return ls; + } else if (! SEXP_PAIRP(ls)) { + return SEXP_ERROR; + } else { + b = ls; + a=cdr(ls); + set_cdr(b, SEXP_NULL); + for ( ; SEXP_PAIRP(a); ) { + tmp = cdr(a); + set_cdr(a, b); + b = a; + a = tmp; + } + return b; + } +} + +sexp list(int count, ...) { + sexp res = SEXP_NULL; + sexp elt; + int i; + va_list ap; + + va_start(ap, count); + for (i=0; itag = SEXP_STRING; + s->data1 = (void*) len; + s->data2 = (void*) mystr; + return s; +} + +sexp intern(char *str) { + sexp sym = SEXP_NEW(); + if (! sym) return SEXP_ERROR; + int len = strlen(str); + char *mystr = SEXP_ALLOC(len+1); + if (! mystr) { SEXP_FREE(sym); return SEXP_ERROR; } + strncpy(mystr, str, len+1); + sym->tag = SEXP_SYMBOL; + sym->data1 = (void*) len; + sym->data2 = (void*) mystr; + return sym; +} + +sexp make_vector(int len, sexp dflt) { + int i; + sexp v = SEXP_NEW(); + if (v == NULL) return SEXP_ERROR; + sexp *x = (void*) SEXP_ALLOC(len*sizeof(sexp)); + if (x == NULL) return SEXP_ERROR; + for (i=0; itag = SEXP_VECTOR; + v->data1 = (void*) len; + v->data2 = (void*) x; + return v; +} + +sexp list_to_vector(sexp ls) { + sexp vec = make_vector(length(ls), SEXP_FALSE); + if (vec == SEXP_ERROR) return vec; + sexp x; + sexp *elts = vector_data(vec); + int i; + for (i=0, x=ls; SEXP_PAIRP(x); i++, x=cdr(x)) { + elts[i] = car(x); + } + return vec; +} + +sexp vector(int count, ...) { + sexp vec = make_vector(count, SEXP_FALSE); + if (vec == SEXP_ERROR) return vec; + sexp *elts = vector_data(vec); + va_list ap; + int i; + + va_start(ap, count); + for (i=0; itag) { + case SEXP_PAIR: + fprintf(out, "("); + write_sexp(out, car(obj)); + for (x=cdr(obj); SEXP_PAIRP(x); x=cdr(x)) { + fprintf(out, " "); + write_sexp(out, car(x)); + } + if (! SEXP_NULLP(x)) { + fprintf(out, " . "); + write_sexp(out, x); + } + fprintf(out, ")"); + break; + case SEXP_VECTOR: + len = vector_length(obj); + sexp *elts = vector_data(obj); + if (len == 0) { + fprintf(out, "#()"); + } else { + fprintf(out, "#("); + write_sexp(out, elts[0]); + for (i=1; itag == SEXP_STRING) { + fprintf(out, "\""); + } + break; + } + + } else if (SEXP_INTEGERP(obj)) { + + fprintf(out, "%d", unbox_integer(obj)); + + } else if (SEXP_CHARP(obj)) { + + if (33 <= unbox_character(obj) < 127) { + fprintf(out, "#\\%c", unbox_character(obj)); + } else { + fprintf(out, "#\\x%02d", unbox_character(obj)); + } + + } else { + + switch ((int) obj) { + case (int) SEXP_NULL: + fprintf(out, "()"); + break; + case (int) SEXP_TRUE: + fprintf(out, "#t"); + break; + case (int) SEXP_FALSE: + fprintf(out, "#f"); + break; + case (int) SEXP_EOF: + fprintf(out, "#"); + break; + case (int) SEXP_UNDEF: + fprintf(out, "#"); + break; + default: + fprintf(out, "#"); + } + } +} + +void* free_sexp (sexp obj) { + int len, i; + sexp *elts; + + if (SEXP_POINTERP(obj)) { + switch (obj->tag) { + case SEXP_PAIR: + free_sexp(car(obj)); + free_sexp(cdr(obj)); + break; + case SEXP_VECTOR: + len = vector_length(obj); + elts = vector_data(obj); + for (i=0; i "); + fflush(stdout); + while ((obj = read_sexp(stdin)) != SEXP_EOF) { + write_sexp(stdout, obj); + fprintf(stdout, "\n> "); + fflush(stdout); + } + fprintf(stdout, "\n"); + return 0; +} diff --git a/sexp-unhuff.c b/sexp-unhuff.c new file mode 100644 index 00000000..fa142e16 --- /dev/null +++ b/sexp-unhuff.c @@ -0,0 +1,71 @@ +/* auto-generated by ./symhuff.scm on Sun Feb 25 23:12:52 2007 */ + +res = c & 7; +c = c >> 3; +if (res == 0) { + res = c & 3; + c = c >> 2; + if (res == 0) { + res = c & 3; + c = c >> 2; + if (res == 0) { + res = c & 7; + c = c >> 3; + if (res == 0) { + res = c & 3; + c = c >> 2; + if (res == 0) { + res = _huff_tab21[c & 7]; + c = c >> 3; + } else if ((res = _huff_tab19[res]) == '\x01') { + res = _huff_tab20[c & 7]; + c = c >> 3; + } + } else if (res == 1) { + res = _huff_tab18[c & 15]; + c = c >> 4; + } else if (res == 2) { + res = _huff_tab17[c & 31]; + c = c >> 5; + } else if (res == 4) { + res = _huff_tab16[c & 15]; + c = c >> 4; + } else if (res == 5) { + res = _huff_tab15[c & 15]; + c = c >> 4; + } else if ((res = _huff_tab13[res]) == '\x00') { + res = _huff_tab14[c & 1]; + c = c >> 1; + } + } else if ((res = _huff_tab11[res]) == '\x00') { + res = _huff_tab12[c & 1]; + c = c >> 1; + } + } else if ((res = _huff_tab9[res]) == '\x00') { + res = _huff_tab10[c & 3]; + c = c >> 2; + } + } else if (res == 1) { + res = _huff_tab8[c & 3]; + c = c >> 2; + } else if (res == 2) { + res = c & 3; + c = c >> 2; + if (res == 0) { + res = _huff_tab7[c & 3]; + c = c >> 2; + } else if ((res = _huff_tab5[res]) == '\x00') { + res = _huff_tab6[c & 1]; + c = c >> 1; + } + } else if (res == 4) { + res = _huff_tab4[c & 1]; + c = c >> 1; + } else if (res == 5) { + res = _huff_tab3[c & 1]; + c = c >> 1; + } else if ((res = _huff_tab1[res]) == '\x00') { + res = _huff_tab2[c & 1]; + c = c >> 1; + } + diff --git a/sexp.c b/sexp.c new file mode 100644 index 00000000..cea2677e --- /dev/null +++ b/sexp.c @@ -0,0 +1,1457 @@ + +#include +#include +#include +#include + +/* simple tagging + * ends in 00: pointer + * 01: fixnum + * 011: symbol + * 111: immediate symbol + * 0110: char + * 1110: other immediate object (NULL, TRUE, FALSE) + */ + +#define SEXP_FIXNUM_BITS 2 +#define SEXP_IMMEDIATE_BITS 3 +#define SEXP_EXTENDED_BITS 4 + +#define SEXP_FIXNUM_MASK 3 +#define SEXP_IMMEDIATE_MASK 7 +#define SEXP_EXTENDED_MASK 15 + +#define SEXP_POINTER_TAG 0 +#define SEXP_FIXNUM_TAG 1 +#define SEXP_LSYMBOL_TAG 3 +#define SEXP_ISYMBOL_TAG 7 +#define SEXP_CHAR_TAG 6 + +enum sexp_types { + SEXP_FIXNUM, + SEXP_CHAR, + SEXP_BOOLEAN, + SEXP_PAIR, + SEXP_SYMBOL, + SEXP_STRING, + SEXP_VECTOR, + SEXP_PROCEDURE, + SEXP_ENV, + SEXP_BYTECODE, + SEXP_CORE, + SEXP_OPCODE, +}; + +typedef struct sexp_struct { + char tag; + void *data1; + void *data2; +} *sexp; + +#include "sexp-hufftabs.c" + +static int 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_lambda_symbol; +static sexp the_begin_symbol; +static sexp the_define_symbol; +static sexp the_set_x_symbol; +static sexp the_if_symbol; + +#define MAKE_IMMEDIATE(n) ((sexp) ((n<<4) + 14)) +#define SEXP_NULL MAKE_IMMEDIATE(0) +#define SEXP_FALSE MAKE_IMMEDIATE(1) +#define SEXP_TRUE MAKE_IMMEDIATE(2) +#define SEXP_EOF MAKE_IMMEDIATE(3) +#define SEXP_UNDEF MAKE_IMMEDIATE(4) +#define SEXP_ERROR MAKE_IMMEDIATE(5) +#define SEXP_CLOSE MAKE_IMMEDIATE(6) /* internal use */ +#define SEXP_RAWDOT MAKE_IMMEDIATE(7) /* internal use */ + +#define SEXP_NULLP(x) ((x) == SEXP_NULL) +#define SEXP_POINTERP(x) (((unsigned long)(x) & SEXP_FIXNUM_MASK) == SEXP_POINTER_TAG) +#define SEXP_INTEGERP(x) (((unsigned long)(x) & SEXP_FIXNUM_MASK) == SEXP_FIXNUM_TAG) +#define SEXP_ISYMBOLP(x) (((unsigned long)(x) & SEXP_IMMEDIATE_MASK) == SEXP_ISYMBOL_TAG) +#define SEXP_CHARP(x) (((unsigned long)(x) & SEXP_EXTENDED_MASK) == SEXP_CHAR_TAG) +#define SEXP_BOOLEANP(x) (((x) == SEXP_TRUE) || ((x) == SEXP_FALSE)) + +#define SEXP_PAIRP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_PAIR) +#define SEXP_STRINGP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_STRING) +#define SEXP_LSYMBOLP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_SYMBOL) +#define SEXP_VECTORP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_VECTOR) +#define SEXP_PROCEDUREP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_PROCEDURE) +#define SEXP_ENVP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_ENV) +#define SEXP_BYTECODEP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag ==SEXP_BYTECODE) +#define SEXP_COREP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_CORE) +#define SEXP_OPCODEP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_OPCODE) + +#define SEXP_SYMBOLP(x) (SEXP_ISYMBOLP(x) || SEXP_LSYMBOLP(x)) + +/* #define SEXP_DOTP(x) (SEXP_SYMBOLP(x) && (strncmp(string_data(x), ".", 2) == 0)) */ +/* #define SEXP_DOTP(x) (x==the_dot_symbol) */ +#define SEXP_DOTP(x) (((unsigned long)(x))==((0x5D00<>SEXP_FIXNUM_BITS) +#define make_character(n) ((sexp) (((long) n<>SEXP_EXTENDED_BITS) + +#define vector_length(x) ((unsigned long) x->data1) +#define vector_data(x) ((sexp*) x->data2) + +#define procedure_code(x) ((bytecode) ((sexp)x)->data1) +#define procedure_vars(x) ((sexp) ((sexp)x)->data2) + +#define string_length(x) ((unsigned long) x->data1) +#define string_data(x) ((char*) x->data2) + +#define symbol_pointer(x) ((sexp) (((unsigned long)x)-SEXP_LSYMBOL_TAG)) +#define symbol_length(x) ((unsigned long) (symbol_pointer(x)->data1)) +#define symbol_data(x) ((char*) (symbol_pointer(x)->data2)) + +#define sexp_add(a, b) ((sexp)(((unsigned long)a)+((unsigned long)b)-SEXP_FIXNUM_TAG)) +#define sexp_sub(a, b) ((sexp)(((unsigned long)a)-((unsigned long)b)+SEXP_FIXNUM_TAG)) +#define sexp_mul(a, b) ((sexp)((((((unsigned long)a)-SEXP_FIXNUM_TAG)*(((unsigned long)b)>>SEXP_FIXNUM_BITS))+SEXP_FIXNUM_TAG))) +#define sexp_div(a, b) ((sexp)(((((unsigned long)a)>>SEXP_FIXNUM_BITS)/(((unsigned long)b)>>SEXP_FIXNUM_BITS))<>SEXP_FIXNUM_BITS)%(((unsigned long)b)>>SEXP_FIXNUM_BITS))<tag = SEXP_PAIR; + pair->data1 = (void*) head; + pair->data2 = (void*) tail; + return pair; +} + +#define list2(a, b) cons(a, cons(b, SEXP_NULL)) +#define list3(a, b, c) cons(a, cons(b, cons(c, SEXP_NULL))) +#define list4(a, b, c, d) cons(a, cons(b, cons(c, cons(d, SEXP_NULL)))) + +#define SEXP_CAR(x) (((sexp)x)->data1) +#define SEXP_CDR(x) (((sexp)x)->data2) + +#define SEXP_CAAR(x) (SEXP_CAR(SEXP_CAR(x))) +#define SEXP_CADR(x) (SEXP_CAR(SEXP_CDR(x))) +#define SEXP_CDAR(x) (SEXP_CDR(SEXP_CAR(x))) +#define SEXP_CDDR(x) (SEXP_CDR(SEXP_CDR(x))) + +#define SEXP_CADDR(x) (SEXP_CAR(SEXP_CDDR(x))) +#define SEXP_CDDDR(x) (SEXP_CDR(SEXP_CDDR(x))) +#define SEXP_CADDDR(x) (SEXP_CADR(SEXP_CDDR(x))) +#define SEXP_CDDDDR(x) (SEXP_CDDR(SEXP_CDDR(x))) + +sexp read_sexp (FILE *in); + +/* separators: space, tab, newline, ; () [] , ' " */ +/* 9 10 11 12 13 32 34 39 40 41 44 59 91 93 */ +/* 0 1 2 3 4 23 25 30 31 32 35 50 82 84 */ +/* 0000000 */ +/* 0000001 */ +/* 0000010 */ +/* 0000011 */ +/* 0000100 */ +/* 0010111 */ +/* 0011001 */ +/* 0011110 */ +/* 0011111 */ +/* 0100000 */ +/* 0100011 */ +/* 0110010 */ +/* 1010010 */ +/* 1010100 */ + +static char 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_ */ + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* x6_ */ + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* x7_ */ +}; + +static int is_separator (int c) { + /* return (!((c-9)&(~3))) | (~(c^4)); */ + return 0tag = SEXP_STRING; + s->data1 = (void*) len; + s->data2 = (void*) mystr; + return s; +} + +struct huff_entry { + unsigned char len; + unsigned short bits; +}; + +static struct huff_entry huff_table[] = { +#include "sexp-huff.c" +}; + +/* http://planetmath.org/encyclopedia/GoodHashTablePrimes.html */ +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; + +#define FNV_PRIME 16777619 +#define FNV_OFFSET_BASIS 2166136261uL + +int string_hash(char *str, int acc) { + while (*str) {acc *= FNV_PRIME; acc ^= *str++;} + return acc; +} + +sexp intern(char *str) { + struct huff_entry he; + unsigned long len, res=FNV_OFFSET_BASIS, space=3, newbits, i, d, cell; + char c, *mystr, *p=str; + sexp sym, *newtable; + + res = 0; + for (p=str; c=*p; p++) { + he = huff_table[c]; + newbits = he.len; + if ((space+newbits) > (sizeof(sexp)*8)) { + goto normal_intern; + } + res |= (((unsigned long) he.bits) << space); + space += newbits; + } + /* fprintf(stderr, "immediate symbol: %x\n", res); */ + return (sexp) (res + SEXP_ISYMBOL_TAG); + + normal_intern: + /* fprintf(stderr, "normal intern\n"); */ + res = string_hash(p, res); + d = symbol_table_primes[symbol_table_prime_index]; + cell = res % d; + for (i=0; i d*4) { + fprintf(stderr, "resizing symbol table\n"); + newtable = malloc(symbol_table_primes[symbol_table_prime_index++] + * sizeof(sexp)); + free(symbol_table); + symbol_table = newtable; + } + + new_entry: + sym = SEXP_NEW(); + if (! sym) return SEXP_ERROR; + len = strlen(str); + mystr = SEXP_ALLOC(len+1); + if (! mystr) { SEXP_FREE(sym); return SEXP_ERROR; } + memcpy(mystr, str, len+1); + sym->tag = SEXP_SYMBOL; + sym->data1 = (void*) len; + sym->data2 = (void*) mystr; + symbol_table[cell] = (sexp) (((unsigned long)sym) + 3); + return symbol_table[cell]; +} + +sexp make_vector(unsigned long len, sexp dflt) { + int i; + sexp v = SEXP_NEW(); + if (v == NULL) return SEXP_ERROR; + sexp *x = (void*) SEXP_ALLOC(len*sizeof(sexp)); + if (x == NULL) return SEXP_ERROR; + for (i=0; itag = SEXP_VECTOR; + v->data1 = (void*) len; + v->data2 = (void*) x; + return v; +} + +sexp list_to_vector(sexp ls) { + sexp vec = make_vector(length(ls), SEXP_FALSE); + if (vec == SEXP_ERROR) return vec; + sexp x; + sexp *elts = vector_data(vec); + int i; + for (i=0, x=ls; SEXP_PAIRP(x); i++, x=cdr(x)) { + elts[i] = car(x); + } + return vec; +} + +sexp vector(int count, ...) { + sexp vec = make_vector(count, SEXP_FALSE); + if (vec == SEXP_ERROR) return vec; + sexp *elts = vector_data(vec); + va_list ap; + int i; + + va_start(ap, count); + for (i=0; i"); + + } else if (SEXP_POINTERP(obj)) { + + switch (obj->tag) { + case SEXP_PAIR: + fprintf(out, "("); + write_sexp(out, car(obj)); + for (x=cdr(obj); SEXP_PAIRP(x); x=cdr(x)) { + fprintf(out, " "); + write_sexp(out, car(x)); + } + if (! SEXP_NULLP(x)) { + fprintf(out, " . "); + write_sexp(out, x); + } + fprintf(out, ")"); + break; + case SEXP_VECTOR: + len = vector_length(obj); + sexp *elts = vector_data(obj); + if (len == 0) { + fprintf(out, "#()"); + } else { + fprintf(out, "#("); + write_sexp(out, elts[0]); + for (i=1; i"); + break; + case SEXP_STRING: + fprintf(out, "\""); + /* FALLTHROUGH */ + case SEXP_SYMBOL: + fprintf(out, "%s", string_data(obj)); + if (obj->tag == SEXP_STRING) { + fprintf(out, "\""); + } + break; + } + + } else if (SEXP_INTEGERP(obj)) { + + fprintf(out, "%d", unbox_integer(obj)); + + } else if (SEXP_CHARP(obj)) { + + if (33 <= unbox_character(obj) < 127) { + fprintf(out, "#\\%c", unbox_character(obj)); + } else { + fprintf(out, "#\\x%02d", unbox_character(obj)); + } + + } else if (SEXP_SYMBOLP(obj)) { + + if (((unsigned long)obj&7)==7) { + + c = ((unsigned long)obj)>>3; + + while (c) { +#include "sexp-unhuff.c" + putc(res, out); + } + + } else { + fprintf(out, "%s", symbol_data(obj)); + } + + } else { + + switch ((unsigned long) obj) { + case (int) SEXP_NULL: + fprintf(out, "()"); + break; + case (int) SEXP_TRUE: + fprintf(out, "#t"); + break; + case (int) SEXP_FALSE: + fprintf(out, "#f"); + break; + case (int) SEXP_EOF: + fprintf(out, "#"); + break; + case (int) SEXP_UNDEF: + fprintf(out, "#"); + break; + default: + fprintf(out, "#"); + } + } +} + +void* free_sexp (sexp obj) { + int len, i; + sexp *elts; + + if (SEXP_POINTERP(obj)) { + switch (obj->tag) { + case SEXP_PAIR: + free_sexp(car(obj)); + free_sexp(cdr(obj)); + break; + case SEXP_VECTOR: + len = vector_length(obj); + elts = vector_data(obj); + for (i=0; i +#else +#define errx(code, msg, ...) (fprintf(stderr,msg"\n",__VA_ARGS__), exit(code)) +#endif + +#define INIT_BCODE_SIZE 128 +#define INIT_STACK_SIZE 1024 + +typedef struct bytecode { + char tag; + unsigned int len; + unsigned char data[]; +} *bytecode; + +/* env binding: #(id chain offset flags) */ +/* chain is the index into the closure parent list (0 for current lambda) */ +/* macros/constants have a value instead of chain */ +typedef struct env { + char tag; + struct env *parent; + sexp bindings; +} *env; + +enum core_form_names { + CORE_DEFINE, + CORE_SET, + CORE_LAMBDA, + CORE_IF, + CORE_BEGIN, + CORE_QUOTE, + CORE_DEFINE_SYNTAX, + CORE_LET_SYNTAX, + CORE_LETREC_SYNTAX, +}; + +typedef struct core_form { + char tag; + char* name; + char code; +} *core_form; + +static struct core_form core_forms[] = { + {SEXP_CORE, "define", CORE_DEFINE}, + {SEXP_CORE, "set!", CORE_SET}, + {SEXP_CORE, "lambda", CORE_LAMBDA}, + {SEXP_CORE, "if", CORE_IF}, + {SEXP_CORE, "begin", CORE_BEGIN}, + {SEXP_CORE, "quote", CORE_QUOTE}, + {SEXP_CORE, "define-syntax", CORE_DEFINE_SYNTAX}, + {SEXP_CORE, "let-syntax", CORE_LET_SYNTAX}, + {SEXP_CORE, "letrec-syntax", CORE_LETREC_SYNTAX}, +}; + +enum opcode_classes { + OPC_GENERIC, + OPC_TYPE_PREDICATE, + OPC_PREDICATE, + OPC_ARITHMETIC, + OPC_ARITHMETIC_INV, + OPC_ARITHMETIC_CMP, + OPC_CONSTRUCTOR, +}; + +/* #define OP_UNSAFE(op) ((op)+128) */ + +enum opcode_names { + OP_NOOP, + OP_STACK_REF, + OP_STACK_SET, + OP_GLOBAL_REF, + OP_GLOBAL_SET, + OP_CLOSURE_REF, + OP_CLOSURE_SET, + OP_PUSH, + OP_DUP, + OP_DROP, + OP_SWAP, + OP_CAR, + OP_CDR, + OP_CONS, + OP_ADD, + OP_SUB, + OP_MUL, + OP_DIV, + OP_MOD, + OP_NEG, + OP_INV, + OP_LT, + OP_CALL, + OP_JUMP_UNLESS, + OP_JUMP, + OP_RET, + OP_DONE, +}; + +typedef struct opcode { + char tag; + char op_class; + char op_name; + char num_args; + char var_args_p; + char arg1_type; + char arg2_type; + char* name; + sexp proc; +} *opcode; + +static struct opcode opcodes[] = { +{SEXP_OPCODE, OPC_TYPE_PREDICATE, OP_CAR, 1, 0, SEXP_PAIR, 0, "car", NULL}, +{SEXP_OPCODE, OPC_TYPE_PREDICATE, OP_CDR, 1, 0, SEXP_PAIR, 0, "cdr", NULL}, +{SEXP_OPCODE, OPC_ARITHMETIC, OP_ADD, 0, 1, SEXP_FIXNUM, 0, "+", NULL}, +{SEXP_OPCODE, OPC_ARITHMETIC_INV, OP_SUB, 0, 1, SEXP_FIXNUM, 0, "-", NULL}, +{SEXP_OPCODE, OPC_ARITHMETIC, OP_MUL, 0, 1, SEXP_FIXNUM, 0, "*", NULL}, +{SEXP_OPCODE, OPC_ARITHMETIC_INV, OP_DIV, 0, 1, SEXP_FIXNUM, 0, "/", NULL}, +{SEXP_OPCODE, OPC_ARITHMETIC, OP_MOD, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, "%", NULL}, +{SEXP_OPCODE, OPC_ARITHMETIC_CMP, OP_LT, 0, 1, SEXP_FIXNUM, 0, "<", NULL}, +}; + +sexp env_cell(env e, sexp key) { + sexp ls, res=NULL; + + do { + for (ls=e->bindings; SEXP_PAIRP(ls); ls=SEXP_CDR(ls)) { + if (SEXP_CAAR(ls) == key) { + res = SEXP_CAR(ls); + break; + } + } + e = e->parent; + } while (e && ! res); + + return res; +} + +sexp make_procedure(sexp bc, sexp vars) { + sexp proc = SEXP_NEW(); + if (! proc) return SEXP_ERROR; + proc->tag = SEXP_PROCEDURE; + proc->data1 = (void*) bc; + proc->data2 = (void*) vars; + return proc; +} + +void env_define(env e, sexp key, sexp value) { + sexp cell = env_cell(e, key); + if (cell) { + SEXP_CDR(cell) = value; + } else { + e->bindings = cons(cons(key, value), e->bindings); + } +} + +env make_standard_env() { + int i; + env e = (env) malloc(sizeof(struct env)); + e->tag = SEXP_ENV; + e->parent = NULL; + e->bindings = SEXP_NULL; + for (i=0; i<(sizeof(core_forms)/sizeof(struct core_form)); i++) { + env_define(e, intern(core_forms[i].name), (sexp)(&core_forms[i])); + } + for (i=0; i<(sizeof(opcodes)/sizeof(struct opcode)); i++) { + env_define(e, intern(opcodes[i].name), (sexp)(&opcodes[i])); + } + return e; +} + +/* ******************************************************************** */ + +/* char *buffncpy(char *buf, unsigned int n, unsigned int len) { */ +/* char *res; */ +/* if (n==len) { */ +/* res = buf; */ +/* } else { */ +/* res = (char*) malloc(n); */ +/* strncpy(res, buf, n); */ +/* free(buf); */ +/* } */ +/* return res; */ +/* } */ + +/* char *buffngrow(char *buf, unsigned int newlen) { */ +/* char *tmp = (char*) malloc(newlen); */ +/* strncpy(tmp, buf, newlen/2); */ +/* free(buf); */ +/* return tmp; */ +/* } */ + +void print_bytecode (bytecode bc) { + int i; + fprintf(stderr, "bytecode @ %p, data @ %p, length = %d\n", bc, bc->data, bc->len); + for (i=0; i+8 < bc->len; i+=8) { + fprintf(stderr, "%02x: %02x %02x %02x %02x %02x %02x %02x %02x\n", i, + bc->data[i], bc->data[i+1], bc->data[i+2], bc->data[i+3], + bc->data[i+4], bc->data[i+5], bc->data[i+6], bc->data[i+7]); + } + if (i != bc->len) { + fprintf(stderr, "%02x:", i); + for ( ; i < bc->len; i++) { + fprintf(stderr, " %02x", bc->data[i]); + } + fprintf(stderr, "\n"); + } +} + +void print_stack (sexp *stack, int top) { + int i; + for (i=0; ilen != i) { + fprintf(stderr, "shrinking to %d\n", i); + tmp = (bytecode) malloc(sizeof(struct bytecode) + i); + tmp->tag = SEXP_BYTECODE; + tmp->len = i; + memcpy(tmp->data, (*bc)->data, i); + SEXP_FREE(*bc); + *bc = tmp; + } +} + +void emit(bytecode *bc, unsigned int *i, char c) { + bytecode tmp; + if ((*bc)->len < (*i)+1) { + fprintf(stderr, "expanding (%d < %d)\n", (*bc)->len, (*i)+1); + tmp = (bytecode) malloc(sizeof(unsigned int) + (*bc)->len*2); + tmp->len = (*bc)->len*2; + memcpy(tmp->data, (*bc)->data, (*bc)->len); + SEXP_FREE(*bc); + *bc = tmp; + } + (*bc)->data[(*i)++] = c; +} + +void emit_word(bytecode *bc, unsigned int *i, unsigned long val) { + bytecode tmp; + if ((*bc)->len < (*i)+4) { + tmp = (bytecode) malloc(sizeof(unsigned int) + (*bc)->len*2); + tmp->len = (*bc)->len*2; + memcpy(tmp->data, (*bc)->data, (*bc)->len); + SEXP_FREE(*bc); + *bc = tmp; + } + *((unsigned long*)(&((*bc)->data[*i]))) = val; + *i += sizeof(unsigned long); +} + +bytecode compile(sexp params, sexp obj, env e, int done_p); +void analyze_app (sexp obj, bytecode *bc, unsigned int *i, + env e, sexp params, unsigned int *d); +void analyze_lambda (sexp name, sexp formals, sexp body, + bytecode *bc, unsigned int *i, env e, + sexp params, unsigned int *d); + +void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, sexp params, unsigned int *d) { + int tmp1, tmp2; + env e2 = e; + sexp o1, o2, cell; + + if (SEXP_PAIRP(obj)) { + /* fprintf(stderr, ":: pair\n"); */ + if (SEXP_SYMBOLP(SEXP_CAR(obj))) { + fprintf(stderr, ":: symbol application\n"); + o1 = env_cell(e, SEXP_CAR(obj)); + /* fprintf(stderr, ":: => %p\n", o1); */ + if (! o1) + errx(1, "unknown operator: %s", SEXP_CAR(obj)); + o1 = SEXP_CDR(o1); + /* fprintf(stderr, ":: => %p\n", o1); */ + if (SEXP_COREP(o1)) { + /* core form */ + fprintf(stderr, ":: core form\n"); + switch (((core_form)o1)->code) { + case CORE_LAMBDA: + fprintf(stderr, ":: lambda\n"); + analyze_lambda(SEXP_FALSE, SEXP_CADR(obj), SEXP_CADDR(obj), + bc, i, e, params, d); + break; + case CORE_DEFINE: + case CORE_SET: + fprintf(stderr, "compiling global set: %p\n", SEXP_CADR(obj)); + if ((((core_form)o1)->code == CORE_DEFINE) + && SEXP_PAIRP(SEXP_CADR(obj))) { + analyze_lambda(SEXP_CAR(SEXP_CADR(obj)), + SEXP_CDR(SEXP_CADR(obj)), + SEXP_CADDR(obj), + bc, i, e, params, d); + } else { + analyze(SEXP_CADDR(obj), bc, i, e, params, d); + } + emit(bc, i, OP_GLOBAL_SET); + emit_word(bc, i, (unsigned long) (SEXP_PAIRP(SEXP_CADR(obj)) + ? SEXP_CAR(SEXP_CADR(obj)) + : SEXP_CADR(obj))); + emit(bc, i, OP_PUSH); + (*d)++; + emit_word(bc, i, (unsigned long) SEXP_UNDEF); + break; + case CORE_BEGIN: + for (o2 = SEXP_CDR(obj); SEXP_PAIRP(o2); o2 = SEXP_CDR(o2)) { + analyze(SEXP_CAR(o2), bc, i, e, params, d); + } + break; + case CORE_IF: + fprintf(stderr, "test clause: %d\n", *i); + analyze(SEXP_CADR(obj), bc, i, e, params, d); + emit(bc, i, OP_JUMP_UNLESS); /* jumps if test fails */ + tmp1 = *i; + emit(bc, i, 0); + fprintf(stderr, "pass clause: %d\n", *i); + analyze(SEXP_CADDR(obj), bc, i, e, params, d); + emit(bc, i, OP_JUMP); + tmp2 = *i; + emit(bc, i, 0); + ((signed char*) (*bc)->data)[tmp1] = (*i)-tmp1-1; /* patch */ + fprintf(stderr, "fail clause: %d\n", *i); + if (SEXP_PAIRP(SEXP_CDDDR(obj))) { + analyze(SEXP_CADDDR(obj), bc, i, e, params, d); + } else { + emit(bc, i, OP_PUSH); + (*d)++; + emit_word(bc, i, (unsigned long) SEXP_UNDEF); + } + ((signed char*) (*bc)->data)[tmp2] = (*i)-tmp2-1; /* patch */ + break; + case CORE_QUOTE: + emit(bc, i, OP_PUSH); + (*d)++; + emit_word(bc, i, (unsigned long)SEXP_CADR(obj)); + break; + default: + errx(1, "unknown core form: %s", ((core_form)o1)->code); + } + } else if (SEXP_OPCODEP(o1)) { + fprintf(stderr, ":: opcode\n"); + /* direct opcode */ + /* verify arity */ + switch (((opcode)o1)->op_class) { + case OPC_TYPE_PREDICATE: + case OPC_PREDICATE: + case OPC_ARITHMETIC: + case OPC_ARITHMETIC_CMP: + /* fprintf(stderr, ":: class: %d\n", ((opcode)o1)->op_class); */ + for (o2 = reverse(SEXP_CDR(obj)); SEXP_PAIRP(o2); o2 = SEXP_CDR(o2)) { + /* fprintf(stderr, ":: arg: %d\n", SEXP_CAR(o2)); */ + analyze(SEXP_CAR(o2), bc, i, e, params, d); + } + fprintf(stderr, ":: name: %d\n", ((opcode)o1)->op_name); + emit(bc, i, ((opcode)o1)->op_name); + (*d) -= length(SEXP_CDDR(obj)); + break; + default: + errx(1, "unknown opcode class: %d", ((opcode)o1)->op_class); + } + } else { + /* function call */ + analyze_app(obj, bc, i, e, params, d); + } + } else if (SEXP_PAIRP(SEXP_CAR(obj))) { + o2 = env_cell(e, SEXP_CAAR(obj)); + if (o2 + && SEXP_COREP(SEXP_CDR(o2)) + && (((core_form)SEXP_CDR(o2))->code == CORE_LAMBDA)) { + /* let */ + } else { + /* computed application */ + analyze_app(obj, bc, i, e, params, d); + } + } else { + errx(1, "invalid operator: %s", SEXP_CAR(obj)); + } + } else if (SEXP_SYMBOLP(obj)) { + /* variable reference */ + /* cell = env_cell(e, obj); */ + fprintf(stderr, "symbol lookup, param length: %d\n", length(params)); + if ((tmp1 = list_index(params, obj)) >= 0) { + fprintf(stderr, "compiling local ref: %p => %d (d = %d)\n", obj, tmp1, *d); + emit(bc, i, OP_STACK_REF); + emit_word(bc, i, tmp1 + *d + 3); + (*d)++; + } else { + fprintf(stderr, "compiling global ref: %p\n", obj); + emit(bc, i, OP_GLOBAL_REF); + emit_word(bc, i, (unsigned long) obj); + (*d)++; + } + } else { + fprintf(stderr, "push: %d\n", (unsigned long)obj); + emit(bc, i, OP_PUSH); + emit_word(bc, i, (unsigned long)obj); + (*d)++; + } +} + +void analyze_app (sexp obj, bytecode *bc, unsigned int *i, + env e, sexp params, unsigned int *d) { + sexp o1; + unsigned long len = length(SEXP_CDR(obj)); + + /* push the arguments onto the stack */ + for (o1 = reverse(SEXP_CDR(obj)); SEXP_PAIRP(o1); o1 = SEXP_CDR(o1)) { + analyze(SEXP_CAR(o1), bc, i, e, params, d); + } + + /* push the operator onto the stack */ + analyze(SEXP_CAR(obj), bc, i, e, params, d); + + /* make the call */ + emit(bc, i, OP_CALL); + emit_word(bc, i, (unsigned long) make_integer(len)); +} + +void analyze_lambda (sexp name, sexp formals, sexp body, + bytecode *bc, unsigned int *i, env e, + sexp params, unsigned int *d) { + sexp obj = (sexp) compile(formals, body, e, 0); + emit(bc, i, OP_PUSH); + (*d)++; + obj = make_procedure(obj, SEXP_NULL); + emit_word(bc, i, (unsigned long) obj); +} + +sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { + unsigned char *ip=bc->data; + sexp cp, tmp; + int i; + + loop: + /* fprintf(stderr, "opcode: %d, ip: %d\n", *ip, ip); */ + /* print_bytecode(bc); */ + switch (*ip++) { + case OP_NOOP: + fprintf(stderr, "noop\n"); + break; + case OP_GLOBAL_REF: + fprintf(stderr, "global ref: ip: %p => %p: ", ip, ((sexp*)ip)[0]); + fflush(stderr); + write_sexp(stderr, ((sexp*)ip)[0]); + fprintf(stderr, "\n"); + tmp = env_cell(e, ((sexp*)ip)[0]); + stack[top++]=SEXP_CDR(tmp); + ip += sizeof(sexp); + break; + case OP_GLOBAL_SET: + fprintf(stderr, "global set: %p: ", ((sexp*)ip)[0]); + fflush(stderr); + write_sexp(stderr, ((sexp*)ip)[0]); + fprintf(stderr, "\n"); + env_define(e, ((sexp*)ip)[0], stack[--top]); + ip += sizeof(sexp); + break; + case OP_STACK_REF: + fprintf(stderr, "stack ref: ip=%p, %d - %d => ", + ip, top, (unsigned long) ((sexp*)ip)[0]); + fflush(stderr); + write_sexp(stderr, stack[top - (unsigned int) ((sexp*)ip)[0]]); + fprintf(stderr, "\n"); + stack[top] = stack[top - (unsigned int) ((sexp*)ip)[0]]; + ip += sizeof(sexp); + top++; + break; + case OP_CLOSURE_REF: + /* stack[top++]=cp[*ip++]; */ + break; + case OP_CLOSURE_SET: + /* cp[*ip++]=stack[top--]; */ + break; + case OP_PUSH: + /* fprintf(stderr, " (push)\n"); */ + stack[top++]=((sexp*)ip)[0]; + ip += sizeof(sexp); + break; + case OP_DUP: + stack[top]=stack[top-1]; + top++; + break; + case OP_DROP: + top--; + break; + case OP_SWAP: + tmp = stack[top-2]; + stack[top-2]=stack[top-1]; + stack[top-1]=tmp; + break; + case OP_CAR: + stack[top-1]=car(stack[top-1]); + break; + case OP_CDR: + stack[top-1]=cdr(stack[top-1]); + break; + case OP_CONS: + stack[top-2]=cons(stack[top-2], stack[top-1]); + top--; + break; + case OP_ADD: + stack[top-2]=sexp_add(stack[top-2],stack[top-1]); + top--; + break; + case OP_SUB: + stack[top-2]=sexp_sub(stack[top-2],stack[top-1]); + top--; + break; + case OP_MUL: + stack[top-2]=sexp_mul(stack[top-2],stack[top-1]); + top--; + break; + case OP_DIV: + stack[top-2]=sexp_div(stack[top-2],stack[top-1]); + top--; + break; + case OP_MOD: + stack[top-2]=sexp_mod(stack[top-2],stack[top-1]); + top--; + break; + case OP_LT: + stack[top-2]=((stack[top-2] < stack[top-1]) ? SEXP_TRUE : SEXP_FALSE); + top--; + break; + case OP_CALL: + fprintf(stderr, "CALL\n"); + i = (unsigned long) ((sexp*)ip)[0]; + tmp = stack[top-1]; + if (! SEXP_PROCEDUREP(tmp)) + errx(2, "non-procedure application: %p", tmp); + stack[top-1] = (sexp) i; + stack[top] = (sexp) (ip+4); + top++; + bc = procedure_code(tmp); + print_bytecode(bc); + ip = bc->data; + fprintf(stderr, "... jumping to procedure at %p\n", ip); + /* print_stack(stack, top); */ + break; + case OP_JUMP_UNLESS: + fprintf(stderr, "JUMP UNLESS, stack top is %d\n", stack[top-1]); + if (stack[--top] == SEXP_FALSE) { + fprintf(stderr, "test passed, jumping to + %d => %d\n", ((signed char*)ip)[0], ip + ((signed char*)ip)[0]); + ip += ((signed char*)ip)[0]; + } else { + fprintf(stderr, "test failed, not jumping\n"); + ip++; + } + break; + case OP_JUMP: + fprintf(stderr, "jumping to + %d => %d\n", ((signed char*)ip)[0], ip + ((signed char*)ip)[0]); + ip += ((signed char*)ip)[0]; + break; + case OP_RET: + fprintf(stderr, "returning @ %d: ", top-1); + fflush(stderr); + write_sexp(stderr, stack[top-1]); + fprintf(stderr, "\n"); + /* print_stack(stack, top); */ + /* top-1 */ + /* stack: args ... n ip result */ + ip = (unsigned char*) stack[top-2]; + i = unbox_integer(stack[top-3]); + stack[top-i-3] = stack[top-1]; + top = top-i-2; + break; + case OP_DONE: + fprintf(stderr, "finally returning @ %d: ", top-1); + fflush(stderr); + write_sexp(stderr, stack[top-1]); + fprintf(stderr, "\n"); + goto end_loop; + default: + fprintf(stderr, "unknown opcode: %d\n", *(ip-1)); + stack[top] = SEXP_ERROR; + goto end_loop; + } + goto loop; + + end_loop: + return stack[top-1]; +} + +bytecode compile(sexp params, sexp obj, env e, int done_p) { + bytecode bc = (bytecode) malloc(sizeof(struct bytecode)+INIT_BCODE_SIZE); + unsigned int i = 0, d = 0; + bc->tag = SEXP_BYTECODE; + bc->len = INIT_BCODE_SIZE; + fprintf(stderr, "analyzing\n"); + analyze(obj, &bc, &i, e, params, &d); + emit(&bc, &i, done_p ? OP_DONE : OP_RET); + /* fprintf(stderr, "shrinking\n"); */ + shrink_bcode(&bc, i); + fprintf(stderr, "done compiling:\n"); + print_bytecode(bc); + return bc; +} + +sexp eval_in_stack(sexp obj, env e, sexp* stack, unsigned int top) { + bytecode bc = compile(SEXP_NULL, obj, e, 1); + fprintf(stderr, "evaling\n"); + return vm(bc, e, stack, top); +} + +sexp eval(sexp obj, env e) { + sexp* stack = (sexp*) malloc(sizeof(sexp) * INIT_STACK_SIZE); + sexp res = eval_in_stack(obj, e, stack, 0); + free(stack); + return res; +} + +int main (int argc, char **argv) { + sexp obj, res, *stack; + env e; + + sexp_init(); + e = make_standard_env(); + stack = (sexp*) malloc(sizeof(sexp) * INIT_STACK_SIZE); + + /* repl */ + fprintf(stdout, "> "); + fflush(stdout); + while ((obj = read_sexp(stdin)) != SEXP_EOF) { + write_sexp(stdout, obj); + fprintf(stdout, "\n => "); + res = eval_in_stack(obj, e, stack, 0); + /* fprintf(stderr, " (=> %d)\n", res); */ + write_sexp(stdout, res); + fprintf(stdout, "\n> "); + fflush(stdout); + } + fprintf(stdout, "\n"); + return 0; +} + From 3a7d12062fb27fff4e435cc536fb3deb28b34fbc Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 1 Mar 2009 14:47:34 +0900 Subject: [PATCH 002/154] moving towards closure support --- sexp.c | 276 +++++++++++++++++++++++++++++++++++++++++++-------------- 1 file changed, 209 insertions(+), 67 deletions(-) diff --git a/sexp.c b/sexp.c index cea2677e..c669fe30 100644 --- a/sexp.c +++ b/sexp.c @@ -108,6 +108,9 @@ static sexp the_if_symbol; #define vector_length(x) ((unsigned long) x->data1) #define vector_data(x) ((sexp*) x->data2) +#define vector_ref(x, i) (vector_data(x)[unbox_integer(i)]) +#define vector_set(x, i, v) (vector_data(x)[unbox_integer(i)] = (v)) + #define procedure_code(x) ((bytecode) ((sexp)x)->data1) #define procedure_vars(x) ((sexp) ((sexp)x)->data2) @@ -203,6 +206,14 @@ sexp set_car(sexp obj, sexp val) { } } +sexp set_cdr(sexp obj, sexp val) { + if (SEXP_PAIRP(obj)) { + return SEXP_CDR(obj) = val; + } else { + return SEXP_ERROR; + } +} + int listp (sexp obj) { while (SEXP_PAIRP(obj)) obj = SEXP_CDR(obj); @@ -220,14 +231,6 @@ int list_index (sexp ls, sexp elt) { return -1; } -sexp set_cdr(sexp obj, sexp val) { - if (SEXP_PAIRP(obj)) { - return SEXP_CDR(obj) = val; - } else { - return SEXP_ERROR; - } -} - sexp reverse(sexp ls) { sexp res = SEXP_NULL; for ( ; SEXP_PAIRP(ls); ls=SEXP_CDR(ls)) @@ -271,6 +274,26 @@ sexp list(int count, ...) { return nreverse(res); } +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 assq (sexp x, sexp ls) { + while (SEXP_PAIRP(ls)) { + if (x == SEXP_CAAR(ls)) + return ls; + else + ls = SEXP_CDR(ls); + } + return SEXP_FALSE; +} + unsigned long length(sexp ls) { sexp x; unsigned long res; @@ -885,31 +908,35 @@ enum opcode_classes { /* #define OP_UNSAFE(op) ((op)+128) */ enum opcode_names { - OP_NOOP, - OP_STACK_REF, - OP_STACK_SET, - OP_GLOBAL_REF, - OP_GLOBAL_SET, - OP_CLOSURE_REF, + OP_NOOP, /* 0 */ + OP_STACK_REF, /* 1 */ + OP_STACK_SET, /* 2 */ + OP_GLOBAL_REF, /* 3 */ + OP_GLOBAL_SET, /* 4 */ + OP_CLOSURE_REF, /* 5 */ OP_CLOSURE_SET, + OP_VECTOR_REF, + OP_VECTOR_SET, /* 8 */ + OP_MAKE_PROCEDURE, + OP_MAKE_VECTOR, OP_PUSH, - OP_DUP, + OP_DUP, /* C */ OP_DROP, OP_SWAP, OP_CAR, - OP_CDR, + OP_CDR, /* 10 */ OP_CONS, OP_ADD, OP_SUB, - OP_MUL, + OP_MUL, /* 14 */ OP_DIV, OP_MOD, OP_NEG, - OP_INV, + OP_INV, /* 18 */ OP_LT, OP_CALL, OP_JUMP_UNLESS, - OP_JUMP, + OP_JUMP, /* 1C */ OP_RET, OP_DONE, }; @@ -923,18 +950,22 @@ typedef struct opcode { char arg1_type; char arg2_type; char* name; + char op_inverse; sexp proc; } *opcode; static struct opcode opcodes[] = { -{SEXP_OPCODE, OPC_TYPE_PREDICATE, OP_CAR, 1, 0, SEXP_PAIR, 0, "car", NULL}, -{SEXP_OPCODE, OPC_TYPE_PREDICATE, OP_CDR, 1, 0, SEXP_PAIR, 0, "cdr", NULL}, -{SEXP_OPCODE, OPC_ARITHMETIC, OP_ADD, 0, 1, SEXP_FIXNUM, 0, "+", NULL}, -{SEXP_OPCODE, OPC_ARITHMETIC_INV, OP_SUB, 0, 1, SEXP_FIXNUM, 0, "-", NULL}, -{SEXP_OPCODE, OPC_ARITHMETIC, OP_MUL, 0, 1, SEXP_FIXNUM, 0, "*", NULL}, -{SEXP_OPCODE, OPC_ARITHMETIC_INV, OP_DIV, 0, 1, SEXP_FIXNUM, 0, "/", NULL}, -{SEXP_OPCODE, OPC_ARITHMETIC, OP_MOD, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, "%", NULL}, -{SEXP_OPCODE, OPC_ARITHMETIC_CMP, OP_LT, 0, 1, SEXP_FIXNUM, 0, "<", NULL}, +{SEXP_OPCODE, OPC_TYPE_PREDICATE, OP_CAR, 1, 0, SEXP_PAIR, 0, "car", 0, NULL}, +{SEXP_OPCODE, OPC_TYPE_PREDICATE, OP_CDR, 1, 0, SEXP_PAIR, 0, "cdr", 0, NULL}, +{SEXP_OPCODE, OPC_ARITHMETIC, OP_ADD, 0, 1, SEXP_FIXNUM, 0, "+", 0, NULL}, +{SEXP_OPCODE, OPC_ARITHMETIC_INV, OP_SUB, 0, 1, SEXP_FIXNUM, 0, "-", OP_NEG, NULL}, +{SEXP_OPCODE, OPC_ARITHMETIC, OP_MUL, 0, 1, SEXP_FIXNUM, 0, "*", 0, NULL}, +{SEXP_OPCODE, OPC_ARITHMETIC_INV, OP_DIV, 0, 1, SEXP_FIXNUM, 0, "/", OP_INV, 0}, +{SEXP_OPCODE, OPC_ARITHMETIC, OP_MOD, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, "%", 0, NULL}, +{SEXP_OPCODE, OPC_ARITHMETIC_CMP, OP_LT, 0, 1, SEXP_FIXNUM, 0, "<", 0, NULL}, +{SEXP_OPCODE, OPC_CONSTRUCTOR, OP_CONS, 2, 0, 0, 0, "cons", 0, NULL}, +{SEXP_OPCODE, OPC_CONSTRUCTOR, OP_MAKE_VECTOR, 2, 0, SEXP_FIXNUM, 0, "make-vector", 0, NULL}, +{SEXP_OPCODE, OPC_CONSTRUCTOR, OP_MAKE_PROCEDURE, 2, 0, 0, 0, "make-procedure", 0, NULL}, }; sexp env_cell(env e, sexp key) { @@ -962,6 +993,16 @@ sexp make_procedure(sexp bc, sexp vars) { return proc; } +int env_global_p (env e, sexp id) { + while (e->parent) { + if (assq(id, e->bindings)) + return 0; + else + e = e->parent; + } + return 1; +} + void env_define(env e, sexp key, sexp value) { sexp cell = env_cell(e, key); if (cell) { @@ -971,6 +1012,18 @@ void env_define(env e, sexp key, sexp value) { } } +env extend_env_closure (env e, sexp fv) { + int i; + env e2 = (env) malloc(sizeof(struct env)); + e2->tag = SEXP_ENV; + e2->parent = e; + e2->bindings = SEXP_NULL; + for (i=0; SEXP_PAIRP(fv); fv = SEXP_CDR(fv), i++) { + e2->bindings = cons(cons(SEXP_CAR(fv), make_integer(i)), e2->bindings); + } + return e2; +} + env make_standard_env() { int i; env e = (env) malloc(sizeof(struct env)); @@ -1079,8 +1132,11 @@ void analyze_app (sexp obj, bytecode *bc, unsigned int *i, void analyze_lambda (sexp name, sexp formals, sexp body, bytecode *bc, unsigned int *i, env e, sexp params, unsigned int *d); +void analyze_var_ref (sexp name, bytecode *bc, unsigned int *i, env e, + sexp params, unsigned int *d); -void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, sexp params, unsigned int *d) { +void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, + sexp params, unsigned int *d) { int tmp1, tmp2; env e2 = e; sexp o1, o2, cell; @@ -1167,15 +1223,27 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, sexp params, unsign case OPC_TYPE_PREDICATE: case OPC_PREDICATE: case OPC_ARITHMETIC: + case OPC_ARITHMETIC_INV: case OPC_ARITHMETIC_CMP: - /* fprintf(stderr, ":: class: %d\n", ((opcode)o1)->op_class); */ - for (o2 = reverse(SEXP_CDR(obj)); SEXP_PAIRP(o2); o2 = SEXP_CDR(o2)) { - /* fprintf(stderr, ":: arg: %d\n", SEXP_CAR(o2)); */ - analyze(SEXP_CAR(o2), bc, i, e, params, d); + if (SEXP_NULLP(SEXP_CDR(obj))) { + errx(1, "unknown opcode class: %d", ((opcode)o1)->op_class); + } else if (SEXP_NULLP(SEXP_CDDR(obj))) { + if (((opcode)o1)->op_class == OPC_ARITHMETIC_INV) { + analyze(SEXP_CADR(obj), bc, i, e, params, d); + emit(bc, i, ((opcode)o1)->op_inverse); + } else { + analyze(SEXP_CADR(obj), bc, i, e, params, d); + } + } else { + /* fprintf(stderr, ":: class: %d\n", ((opcode)o1)->op_class); */ + for (o2 = reverse(SEXP_CDR(obj)); SEXP_PAIRP(o2); o2 = SEXP_CDR(o2)) { + /* fprintf(stderr, ":: arg: %d\n", SEXP_CAR(o2)); */ + analyze(SEXP_CAR(o2), bc, i, e, params, d); + } + fprintf(stderr, ":: name: %d\n", ((opcode)o1)->op_name); + emit(bc, i, ((opcode)o1)->op_name); + (*d) -= length(SEXP_CDDR(obj)); } - fprintf(stderr, ":: name: %d\n", ((opcode)o1)->op_name); - emit(bc, i, ((opcode)o1)->op_name); - (*d) -= length(SEXP_CDDR(obj)); break; default: errx(1, "unknown opcode class: %d", ((opcode)o1)->op_class); @@ -1186,32 +1254,19 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, sexp params, unsign } } else if (SEXP_PAIRP(SEXP_CAR(obj))) { o2 = env_cell(e, SEXP_CAAR(obj)); - if (o2 - && SEXP_COREP(SEXP_CDR(o2)) - && (((core_form)SEXP_CDR(o2))->code == CORE_LAMBDA)) { - /* let */ - } else { +/* if (o2 */ +/* && SEXP_COREP(SEXP_CDR(o2)) */ +/* && (((core_form)SEXP_CDR(o2))->code == CORE_LAMBDA)) { */ +/* /\* let *\/ */ +/* } else { */ /* computed application */ analyze_app(obj, bc, i, e, params, d); - } +/* } */ } else { errx(1, "invalid operator: %s", SEXP_CAR(obj)); } } else if (SEXP_SYMBOLP(obj)) { - /* variable reference */ - /* cell = env_cell(e, obj); */ - fprintf(stderr, "symbol lookup, param length: %d\n", length(params)); - if ((tmp1 = list_index(params, obj)) >= 0) { - fprintf(stderr, "compiling local ref: %p => %d (d = %d)\n", obj, tmp1, *d); - emit(bc, i, OP_STACK_REF); - emit_word(bc, i, tmp1 + *d + 3); - (*d)++; - } else { - fprintf(stderr, "compiling global ref: %p\n", obj); - emit(bc, i, OP_GLOBAL_REF); - emit_word(bc, i, (unsigned long) obj); - (*d)++; - } + analyze_var_ref (obj, bc, i, e, params, d); } else { fprintf(stderr, "push: %d\n", (unsigned long)obj); emit(bc, i, OP_PUSH); @@ -1220,6 +1275,25 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, sexp params, unsign } } +void analyze_var_ref (sexp obj, bytecode *bc, unsigned int *i, env e, + sexp params, unsigned int *d) { + int tmp; + /* variable reference */ + /* cell = env_cell(e, obj); */ + fprintf(stderr, "symbol lookup, param length: %d\n", length(params)); + if ((tmp = list_index(params, obj)) >= 0) { + fprintf(stderr, "compiling local ref: %p => %d (d = %d)\n", obj, tmp, *d); + emit(bc, i, OP_STACK_REF); + emit_word(bc, i, tmp + *d + 4); + (*d)++; + } else { + fprintf(stderr, "compiling global ref: %p\n", obj); + emit(bc, i, OP_GLOBAL_REF); + emit_word(bc, i, (unsigned long) obj); + (*d)++; + } +} + void analyze_app (sexp obj, bytecode *bc, unsigned int *i, env e, sexp params, unsigned int *d) { sexp o1; @@ -1238,14 +1312,60 @@ void analyze_app (sexp obj, bytecode *bc, unsigned int *i, emit_word(bc, i, (unsigned long) make_integer(len)); } +sexp free_vars (env e, sexp formals, sexp obj, sexp fv) { + sexp o1; + if (SEXP_SYMBOLP(obj)) { + if (env_global_p(e, obj) + || (list_index(formals, obj) >= 0) + || (list_index(fv, obj) >= 0)) + return fv; + else + return cons(obj, fv); + } else if (SEXP_PAIRP(obj)) { + if (SEXP_SYMBOLP(SEXP_CAR(obj))) { + if ((o1 = env_cell(e, SEXP_CAR(obj))) + && SEXP_COREP(o1) + && (((core_form)SEXP_CDR(o1))->code == CORE_LAMBDA)) { + return free_vars(e, SEXP_CADR(obj), SEXP_CADDR(obj), fv); + } + } + while (SEXP_PAIRP(obj)) { + fv = free_vars(e, formals, SEXP_CAR(obj), fv); + obj = SEXP_CDR(obj); + } + return fv; + } else { + return fv; + } +} + void analyze_lambda (sexp name, sexp formals, sexp body, bytecode *bc, unsigned int *i, env e, sexp params, unsigned int *d) { - sexp obj = (sexp) compile(formals, body, e, 0); + sexp obj; + sexp fv = free_vars(e, formals, body, SEXP_NULL), ls; + env e2 = extend_env_closure(e, formals); + int k; + obj = (sexp) compile(formals, body, e2, 0); emit(bc, i, OP_PUSH); + emit_word(bc, i, (unsigned long) SEXP_UNDEF); + emit(bc, i, OP_PUSH); + emit_word(bc, i, (unsigned long) make_integer(length(fv))); + emit(bc, i, OP_MAKE_VECTOR); (*d)++; - obj = make_procedure(obj, SEXP_NULL); + for (ls=fv, k=0; SEXP_PAIRP(ls); ls=SEXP_CDR(ls), k++) { + analyze_var_ref(SEXP_CAR(ls), bc, i, e, params, d); + emit(bc, i, OP_PUSH); + emit_word(bc, i, (unsigned long) make_integer(k)); + emit(bc, i, OP_STACK_REF); + emit_word(bc, i, 2); + emit(bc, i, OP_VECTOR_SET); + emit(bc, i, OP_DROP); + (*d)--; + } + emit(bc, i, OP_PUSH); emit_word(bc, i, (unsigned long) obj); + emit(bc, i, OP_MAKE_PROCEDURE); } sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { @@ -1288,10 +1408,28 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { top++; break; case OP_CLOSURE_REF: - /* stack[top++]=cp[*ip++]; */ + stack[top++]=vector_ref(cp,((sexp*)ip)[0]); + ip += sizeof(sexp); break; - case OP_CLOSURE_SET: - /* cp[*ip++]=stack[top--]; */ +/* case OP_CLOSURE_SET: */ +/* cp[*ip++]=stack[--top]; */ +/* break; */ + case OP_VECTOR_REF: + stack[top-2]=vector_ref(stack[top-1], stack[top-2]); + top--; + break; + case OP_VECTOR_SET: + vector_set(stack[top-1], stack[top-2], stack[top-3]); + stack[top-3]=SEXP_UNDEF; + top-=2; + break; + case OP_MAKE_PROCEDURE: + stack[top-2]=make_procedure(stack[top-1], stack[top-2]); + top--; + break; + case OP_MAKE_VECTOR: + stack[top-2]=make_vector(unbox_integer(stack[top-2]), stack[top-1]); + top--; break; case OP_PUSH: /* fprintf(stderr, " (push)\n"); */ @@ -1321,11 +1459,12 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { top--; break; case OP_ADD: + fprintf(stderr, "OP_ADD %d %d\n", unbox_integer(stack[top-2]), unbox_integer(stack[top-1])); stack[top-2]=sexp_add(stack[top-2],stack[top-1]); top--; break; case OP_SUB: - stack[top-2]=sexp_sub(stack[top-2],stack[top-1]); + stack[top-2]=sexp_sub(stack[top-1],stack[top-2]); top--; break; case OP_MUL: @@ -1352,11 +1491,13 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { errx(2, "non-procedure application: %p", tmp); stack[top-1] = (sexp) i; stack[top] = (sexp) (ip+4); - top++; + stack[top+1] = cp; + top+=2; bc = procedure_code(tmp); print_bytecode(bc); ip = bc->data; - fprintf(stderr, "... jumping to procedure at %p\n", ip); + cp = procedure_vars(tmp); + fprintf(stderr, "... calling procedure at %p\n", ip); /* print_stack(stack, top); */ break; case OP_JUMP_UNLESS: @@ -1381,10 +1522,11 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { /* print_stack(stack, top); */ /* top-1 */ /* stack: args ... n ip result */ - ip = (unsigned char*) stack[top-2]; - i = unbox_integer(stack[top-3]); - stack[top-i-3] = stack[top-1]; - top = top-i-2; + cp = stack[top-2]; + ip = (unsigned char*) stack[top-3]; + i = unbox_integer(stack[top-4]); + stack[top-i-4] = stack[top-1]; + top = top-i-3; break; case OP_DONE: fprintf(stderr, "finally returning @ %d: ", top-1); From dd6dd392c82c069540e8c74551237985c0e6a382 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 1 Mar 2009 15:23:32 +0900 Subject: [PATCH 003/154] more fun with closures, adding -/ support --- sexp.c | 73 ++++++++++++++++++++++++++++++++-------------------------- 1 file changed, 40 insertions(+), 33 deletions(-) diff --git a/sexp.c b/sexp.c index c669fe30..74ba4e2f 100644 --- a/sexp.c +++ b/sexp.c @@ -995,7 +995,7 @@ sexp make_procedure(sexp bc, sexp vars) { int env_global_p (env e, sexp id) { while (e->parent) { - if (assq(id, e->bindings)) + if (assq(id, e->bindings) != SEXP_FALSE) return 0; else e = e->parent; @@ -1126,17 +1126,17 @@ void emit_word(bytecode *bc, unsigned int *i, unsigned long val) { *i += sizeof(unsigned long); } -bytecode compile(sexp params, sexp obj, env e, int done_p); +bytecode compile(sexp params, sexp obj, env e, sexp fv, int done_p); void analyze_app (sexp obj, bytecode *bc, unsigned int *i, - env e, sexp params, unsigned int *d); + env e, sexp params, sexp fv, unsigned int *d); void analyze_lambda (sexp name, sexp formals, sexp body, bytecode *bc, unsigned int *i, env e, - sexp params, unsigned int *d); + sexp params, sexp fv, unsigned int *d); void analyze_var_ref (sexp name, bytecode *bc, unsigned int *i, env e, - sexp params, unsigned int *d); + sexp params, sexp fv, unsigned int *d); void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, - sexp params, unsigned int *d) { + sexp params, sexp fv, unsigned int *d) { int tmp1, tmp2; env e2 = e; sexp o1, o2, cell; @@ -1158,7 +1158,7 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, case CORE_LAMBDA: fprintf(stderr, ":: lambda\n"); analyze_lambda(SEXP_FALSE, SEXP_CADR(obj), SEXP_CADDR(obj), - bc, i, e, params, d); + bc, i, e, params, fv, d); break; case CORE_DEFINE: case CORE_SET: @@ -1168,9 +1168,9 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, analyze_lambda(SEXP_CAR(SEXP_CADR(obj)), SEXP_CDR(SEXP_CADR(obj)), SEXP_CADDR(obj), - bc, i, e, params, d); + bc, i, e, params, fv, d); } else { - analyze(SEXP_CADDR(obj), bc, i, e, params, d); + analyze(SEXP_CADDR(obj), bc, i, e, params, fv, d); } emit(bc, i, OP_GLOBAL_SET); emit_word(bc, i, (unsigned long) (SEXP_PAIRP(SEXP_CADR(obj)) @@ -1182,24 +1182,24 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, break; case CORE_BEGIN: for (o2 = SEXP_CDR(obj); SEXP_PAIRP(o2); o2 = SEXP_CDR(o2)) { - analyze(SEXP_CAR(o2), bc, i, e, params, d); + analyze(SEXP_CAR(o2), bc, i, e, params, fv, d); } break; case CORE_IF: fprintf(stderr, "test clause: %d\n", *i); - analyze(SEXP_CADR(obj), bc, i, e, params, d); + analyze(SEXP_CADR(obj), bc, i, e, params, fv, d); emit(bc, i, OP_JUMP_UNLESS); /* jumps if test fails */ tmp1 = *i; emit(bc, i, 0); fprintf(stderr, "pass clause: %d\n", *i); - analyze(SEXP_CADDR(obj), bc, i, e, params, d); + analyze(SEXP_CADDR(obj), bc, i, e, params, fv, d); emit(bc, i, OP_JUMP); tmp2 = *i; emit(bc, i, 0); ((signed char*) (*bc)->data)[tmp1] = (*i)-tmp1-1; /* patch */ fprintf(stderr, "fail clause: %d\n", *i); if (SEXP_PAIRP(SEXP_CDDDR(obj))) { - analyze(SEXP_CADDDR(obj), bc, i, e, params, d); + analyze(SEXP_CADDDR(obj), bc, i, e, params, fv, d); } else { emit(bc, i, OP_PUSH); (*d)++; @@ -1229,16 +1229,16 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, errx(1, "unknown opcode class: %d", ((opcode)o1)->op_class); } else if (SEXP_NULLP(SEXP_CDDR(obj))) { if (((opcode)o1)->op_class == OPC_ARITHMETIC_INV) { - analyze(SEXP_CADR(obj), bc, i, e, params, d); + analyze(SEXP_CADR(obj), bc, i, e, params, fv, d); emit(bc, i, ((opcode)o1)->op_inverse); } else { - analyze(SEXP_CADR(obj), bc, i, e, params, d); + analyze(SEXP_CADR(obj), bc, i, e, params, fv, d); } } else { /* fprintf(stderr, ":: class: %d\n", ((opcode)o1)->op_class); */ for (o2 = reverse(SEXP_CDR(obj)); SEXP_PAIRP(o2); o2 = SEXP_CDR(o2)) { /* fprintf(stderr, ":: arg: %d\n", SEXP_CAR(o2)); */ - analyze(SEXP_CAR(o2), bc, i, e, params, d); + analyze(SEXP_CAR(o2), bc, i, e, params, fv, d); } fprintf(stderr, ":: name: %d\n", ((opcode)o1)->op_name); emit(bc, i, ((opcode)o1)->op_name); @@ -1250,7 +1250,7 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, } } else { /* function call */ - analyze_app(obj, bc, i, e, params, d); + analyze_app(obj, bc, i, e, params, fv, d); } } else if (SEXP_PAIRP(SEXP_CAR(obj))) { o2 = env_cell(e, SEXP_CAAR(obj)); @@ -1260,13 +1260,13 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, /* /\* let *\/ */ /* } else { */ /* computed application */ - analyze_app(obj, bc, i, e, params, d); + analyze_app(obj, bc, i, e, params, fv, d); /* } */ } else { errx(1, "invalid operator: %s", SEXP_CAR(obj)); } } else if (SEXP_SYMBOLP(obj)) { - analyze_var_ref (obj, bc, i, e, params, d); + analyze_var_ref (obj, bc, i, e, params, fv, d); } else { fprintf(stderr, "push: %d\n", (unsigned long)obj); emit(bc, i, OP_PUSH); @@ -1276,7 +1276,7 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, } void analyze_var_ref (sexp obj, bytecode *bc, unsigned int *i, env e, - sexp params, unsigned int *d) { + sexp params, sexp fv, unsigned int *d) { int tmp; /* variable reference */ /* cell = env_cell(e, obj); */ @@ -1286,6 +1286,11 @@ void analyze_var_ref (sexp obj, bytecode *bc, unsigned int *i, env e, emit(bc, i, OP_STACK_REF); emit_word(bc, i, tmp + *d + 4); (*d)++; + } else if ((tmp = list_index(fv, obj)) >= 0) { + fprintf(stderr, "compiling closure ref: %p => %d\n", obj, tmp); + emit(bc, i, OP_CLOSURE_REF); + emit_word(bc, i, tmp); + (*d)++; } else { fprintf(stderr, "compiling global ref: %p\n", obj); emit(bc, i, OP_GLOBAL_REF); @@ -1295,17 +1300,17 @@ void analyze_var_ref (sexp obj, bytecode *bc, unsigned int *i, env e, } void analyze_app (sexp obj, bytecode *bc, unsigned int *i, - env e, sexp params, unsigned int *d) { + env e, sexp params, sexp fv, unsigned int *d) { sexp o1; unsigned long len = length(SEXP_CDR(obj)); /* push the arguments onto the stack */ for (o1 = reverse(SEXP_CDR(obj)); SEXP_PAIRP(o1); o1 = SEXP_CDR(o1)) { - analyze(SEXP_CAR(o1), bc, i, e, params, d); + analyze(SEXP_CAR(o1), bc, i, e, params, fv, d); } /* push the operator onto the stack */ - analyze(SEXP_CAR(obj), bc, i, e, params, d); + analyze(SEXP_CAR(obj), bc, i, e, params, fv, d); /* make the call */ emit(bc, i, OP_CALL); @@ -1341,20 +1346,23 @@ sexp free_vars (env e, sexp formals, sexp obj, sexp fv) { void analyze_lambda (sexp name, sexp formals, sexp body, bytecode *bc, unsigned int *i, env e, - sexp params, unsigned int *d) { + sexp params, sexp fv, unsigned int *d) { sexp obj; - sexp fv = free_vars(e, formals, body, SEXP_NULL), ls; + sexp fv2 = free_vars(e, formals, body, SEXP_NULL), ls; env e2 = extend_env_closure(e, formals); int k; - obj = (sexp) compile(formals, body, e2, 0); + fprintf(stderr, "%d free-vars\n", length(fv2)); + write_sexp(stderr, fv2); + fprintf(stderr, "\n"); + obj = (sexp) compile(formals, body, e2, fv2, 0); emit(bc, i, OP_PUSH); emit_word(bc, i, (unsigned long) SEXP_UNDEF); emit(bc, i, OP_PUSH); - emit_word(bc, i, (unsigned long) make_integer(length(fv))); + emit_word(bc, i, (unsigned long) make_integer(length(fv2))); emit(bc, i, OP_MAKE_VECTOR); (*d)++; for (ls=fv, k=0; SEXP_PAIRP(ls); ls=SEXP_CDR(ls), k++) { - analyze_var_ref(SEXP_CAR(ls), bc, i, e, params, d); + analyze_var_ref(SEXP_CAR(ls), bc, i, e, params, fv, d); emit(bc, i, OP_PUSH); emit_word(bc, i, (unsigned long) make_integer(k)); emit(bc, i, OP_STACK_REF); @@ -1459,8 +1467,7 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { top--; break; case OP_ADD: - fprintf(stderr, "OP_ADD %d %d\n", unbox_integer(stack[top-2]), unbox_integer(stack[top-1])); - stack[top-2]=sexp_add(stack[top-2],stack[top-1]); + stack[top-2]=sexp_add(stack[top-1],stack[top-2]); top--; break; case OP_SUB: @@ -1545,13 +1552,13 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { return stack[top-1]; } -bytecode compile(sexp params, sexp obj, env e, int done_p) { +bytecode compile(sexp params, sexp obj, env e, sexp fv, int done_p) { bytecode bc = (bytecode) malloc(sizeof(struct bytecode)+INIT_BCODE_SIZE); unsigned int i = 0, d = 0; bc->tag = SEXP_BYTECODE; bc->len = INIT_BCODE_SIZE; fprintf(stderr, "analyzing\n"); - analyze(obj, &bc, &i, e, params, &d); + analyze(obj, &bc, &i, e, params, fv, &d); emit(&bc, &i, done_p ? OP_DONE : OP_RET); /* fprintf(stderr, "shrinking\n"); */ shrink_bcode(&bc, i); @@ -1561,7 +1568,7 @@ bytecode compile(sexp params, sexp obj, env e, int done_p) { } sexp eval_in_stack(sexp obj, env e, sexp* stack, unsigned int top) { - bytecode bc = compile(SEXP_NULL, obj, e, 1); + bytecode bc = compile(SEXP_NULL, obj, e, SEXP_NULL, 1); fprintf(stderr, "evaling\n"); return vm(bc, e, stack, top); } From 107566d680b1907e02c9e718788366ed3f15b3f9 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 1 Mar 2009 15:37:42 +0900 Subject: [PATCH 004/154] initial closures seem to be working! --- sexp.c | 18 ++++++++++++++---- 1 file changed, 14 insertions(+), 4 deletions(-) diff --git a/sexp.c b/sexp.c index 74ba4e2f..19788e0a 100644 --- a/sexp.c +++ b/sexp.c @@ -1361,12 +1361,12 @@ void analyze_lambda (sexp name, sexp formals, sexp body, emit_word(bc, i, (unsigned long) make_integer(length(fv2))); emit(bc, i, OP_MAKE_VECTOR); (*d)++; - for (ls=fv, k=0; SEXP_PAIRP(ls); ls=SEXP_CDR(ls), k++) { + for (ls=fv2, k=0; SEXP_PAIRP(ls); ls=SEXP_CDR(ls), k++) { analyze_var_ref(SEXP_CAR(ls), bc, i, e, params, fv, d); emit(bc, i, OP_PUSH); emit_word(bc, i, (unsigned long) make_integer(k)); emit(bc, i, OP_STACK_REF); - emit_word(bc, i, 2); + emit_word(bc, i, 3); emit(bc, i, OP_VECTOR_SET); emit(bc, i, OP_DROP); (*d)--; @@ -1416,6 +1416,10 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { top++; break; case OP_CLOSURE_REF: + fprintf(stderr, "closure-ref %d => ", ((sexp*)ip)[0]); + fflush(stderr); + write_sexp(stderr, vector_ref(cp,((sexp*)ip)[0])); + fprintf(stderr, "\n"); stack[top++]=vector_ref(cp,((sexp*)ip)[0]); ip += sizeof(sexp); break; @@ -1427,6 +1431,9 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { top--; break; case OP_VECTOR_SET: + fprintf(stderr, "vector-set! %p %d => ", stack[top-1], unbox_integer(stack[top-2])); + write_sexp(stderr, stack[top-3]); + fprintf(stderr, "\n"); vector_set(stack[top-1], stack[top-2], stack[top-3]); stack[top-3]=SEXP_UNDEF; top-=2; @@ -1436,7 +1443,7 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { top--; break; case OP_MAKE_VECTOR: - stack[top-2]=make_vector(unbox_integer(stack[top-2]), stack[top-1]); + stack[top-2]=make_vector(unbox_integer(stack[top-1]), stack[top-2]); top--; break; case OP_PUSH: @@ -1467,6 +1474,7 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { top--; break; case OP_ADD: + fprintf(stderr, "OP_ADD %d %d\n", stack[top-1], stack[top-2]); stack[top-2]=sexp_add(stack[top-1],stack[top-2]); top--; break; @@ -1504,7 +1512,9 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { print_bytecode(bc); ip = bc->data; cp = procedure_vars(tmp); - fprintf(stderr, "... calling procedure at %p\n", ip); + fprintf(stderr, "... calling procedure at %p\ncp: ", ip); + write_sexp(stderr, cp); + fprintf(stderr, "\n"); /* print_stack(stack, top); */ break; case OP_JUMP_UNLESS: From dec08e9cfa34705f6543b21d9e777bee5025b7ca Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 1 Mar 2009 15:54:46 +0900 Subject: [PATCH 005/154] preparing for set! support --- sexp.c | 66 ++++++++++++++++++++++++++++++++-------------------------- 1 file changed, 36 insertions(+), 30 deletions(-) diff --git a/sexp.c b/sexp.c index 19788e0a..9c7c825f 100644 --- a/sexp.c +++ b/sexp.c @@ -1063,14 +1063,20 @@ env make_standard_env() { void print_bytecode (bytecode bc) { int i; fprintf(stderr, "bytecode @ %p, data @ %p, length = %d\n", bc, bc->data, bc->len); - for (i=0; i+8 < bc->len; i+=8) { - fprintf(stderr, "%02x: %02x %02x %02x %02x %02x %02x %02x %02x\n", i, + for (i=0; i+16 < bc->len; i+=8) { + fprintf(stderr, "%02x: %02x %02x %02x %02x %02x %02x %02x %02x ", i, + bc->data[i], bc->data[i+1], bc->data[i+2], bc->data[i+3], + bc->data[i+4], bc->data[i+5], bc->data[i+6], bc->data[i+7]); + i += 8; + fprintf(stderr, "%02x %02x %02x %02x %02x %02x %02x %02x\n", bc->data[i], bc->data[i+1], bc->data[i+2], bc->data[i+3], bc->data[i+4], bc->data[i+5], bc->data[i+6], bc->data[i+7]); } if (i != bc->len) { fprintf(stderr, "%02x:", i); for ( ; i < bc->len; i++) { + if ((i % 8) == 0 && (i % 16) != 0) + fprintf(stderr, " "); fprintf(stderr, " %02x", bc->data[i]); } fprintf(stderr, "\n"); @@ -1126,17 +1132,17 @@ void emit_word(bytecode *bc, unsigned int *i, unsigned long val) { *i += sizeof(unsigned long); } -bytecode compile(sexp params, sexp obj, env e, sexp fv, int done_p); +bytecode compile(sexp params, sexp obj, env e, sexp fv, sexp sv, int done_p); void analyze_app (sexp obj, bytecode *bc, unsigned int *i, - env e, sexp params, sexp fv, unsigned int *d); + env e, sexp params, sexp fv, sexp sv, unsigned int *d); void analyze_lambda (sexp name, sexp formals, sexp body, bytecode *bc, unsigned int *i, env e, - sexp params, sexp fv, unsigned int *d); + sexp params, sexp fv, sexp sv, unsigned int *d); void analyze_var_ref (sexp name, bytecode *bc, unsigned int *i, env e, - sexp params, sexp fv, unsigned int *d); + sexp params, sexp fv, sexp sv, unsigned int *d); void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, - sexp params, sexp fv, unsigned int *d) { + sexp params, sexp fv, sexp sv, unsigned int *d) { int tmp1, tmp2; env e2 = e; sexp o1, o2, cell; @@ -1158,7 +1164,7 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, case CORE_LAMBDA: fprintf(stderr, ":: lambda\n"); analyze_lambda(SEXP_FALSE, SEXP_CADR(obj), SEXP_CADDR(obj), - bc, i, e, params, fv, d); + bc, i, e, params, fv, sv, d); break; case CORE_DEFINE: case CORE_SET: @@ -1168,9 +1174,9 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, analyze_lambda(SEXP_CAR(SEXP_CADR(obj)), SEXP_CDR(SEXP_CADR(obj)), SEXP_CADDR(obj), - bc, i, e, params, fv, d); + bc, i, e, params, fv, sv, d); } else { - analyze(SEXP_CADDR(obj), bc, i, e, params, fv, d); + analyze(SEXP_CADDR(obj), bc, i, e, params, fv, sv, d); } emit(bc, i, OP_GLOBAL_SET); emit_word(bc, i, (unsigned long) (SEXP_PAIRP(SEXP_CADR(obj)) @@ -1182,24 +1188,24 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, break; case CORE_BEGIN: for (o2 = SEXP_CDR(obj); SEXP_PAIRP(o2); o2 = SEXP_CDR(o2)) { - analyze(SEXP_CAR(o2), bc, i, e, params, fv, d); + analyze(SEXP_CAR(o2), bc, i, e, params, fv, sv, d); } break; case CORE_IF: fprintf(stderr, "test clause: %d\n", *i); - analyze(SEXP_CADR(obj), bc, i, e, params, fv, d); + analyze(SEXP_CADR(obj), bc, i, e, params, fv, sv, d); emit(bc, i, OP_JUMP_UNLESS); /* jumps if test fails */ tmp1 = *i; emit(bc, i, 0); fprintf(stderr, "pass clause: %d\n", *i); - analyze(SEXP_CADDR(obj), bc, i, e, params, fv, d); + analyze(SEXP_CADDR(obj), bc, i, e, params, fv, sv, d); emit(bc, i, OP_JUMP); tmp2 = *i; emit(bc, i, 0); ((signed char*) (*bc)->data)[tmp1] = (*i)-tmp1-1; /* patch */ fprintf(stderr, "fail clause: %d\n", *i); if (SEXP_PAIRP(SEXP_CDDDR(obj))) { - analyze(SEXP_CADDDR(obj), bc, i, e, params, fv, d); + analyze(SEXP_CADDDR(obj), bc, i, e, params, fv, sv, d); } else { emit(bc, i, OP_PUSH); (*d)++; @@ -1229,16 +1235,16 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, errx(1, "unknown opcode class: %d", ((opcode)o1)->op_class); } else if (SEXP_NULLP(SEXP_CDDR(obj))) { if (((opcode)o1)->op_class == OPC_ARITHMETIC_INV) { - analyze(SEXP_CADR(obj), bc, i, e, params, fv, d); + analyze(SEXP_CADR(obj), bc, i, e, params, fv, sv, d); emit(bc, i, ((opcode)o1)->op_inverse); } else { - analyze(SEXP_CADR(obj), bc, i, e, params, fv, d); + analyze(SEXP_CADR(obj), bc, i, e, params, fv, sv, d); } } else { /* fprintf(stderr, ":: class: %d\n", ((opcode)o1)->op_class); */ for (o2 = reverse(SEXP_CDR(obj)); SEXP_PAIRP(o2); o2 = SEXP_CDR(o2)) { /* fprintf(stderr, ":: arg: %d\n", SEXP_CAR(o2)); */ - analyze(SEXP_CAR(o2), bc, i, e, params, fv, d); + analyze(SEXP_CAR(o2), bc, i, e, params, fv, sv, d); } fprintf(stderr, ":: name: %d\n", ((opcode)o1)->op_name); emit(bc, i, ((opcode)o1)->op_name); @@ -1250,7 +1256,7 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, } } else { /* function call */ - analyze_app(obj, bc, i, e, params, fv, d); + analyze_app(obj, bc, i, e, params, fv, sv, d); } } else if (SEXP_PAIRP(SEXP_CAR(obj))) { o2 = env_cell(e, SEXP_CAAR(obj)); @@ -1260,13 +1266,13 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, /* /\* let *\/ */ /* } else { */ /* computed application */ - analyze_app(obj, bc, i, e, params, fv, d); + analyze_app(obj, bc, i, e, params, fv, sv, d); /* } */ } else { errx(1, "invalid operator: %s", SEXP_CAR(obj)); } } else if (SEXP_SYMBOLP(obj)) { - analyze_var_ref (obj, bc, i, e, params, fv, d); + analyze_var_ref (obj, bc, i, e, params, fv, sv, d); } else { fprintf(stderr, "push: %d\n", (unsigned long)obj); emit(bc, i, OP_PUSH); @@ -1276,7 +1282,7 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, } void analyze_var_ref (sexp obj, bytecode *bc, unsigned int *i, env e, - sexp params, sexp fv, unsigned int *d) { + sexp params, sexp fv, sexp sv, unsigned int *d) { int tmp; /* variable reference */ /* cell = env_cell(e, obj); */ @@ -1300,17 +1306,17 @@ void analyze_var_ref (sexp obj, bytecode *bc, unsigned int *i, env e, } void analyze_app (sexp obj, bytecode *bc, unsigned int *i, - env e, sexp params, sexp fv, unsigned int *d) { + env e, sexp params, sexp fv, sexp sv, unsigned int *d) { sexp o1; unsigned long len = length(SEXP_CDR(obj)); /* push the arguments onto the stack */ for (o1 = reverse(SEXP_CDR(obj)); SEXP_PAIRP(o1); o1 = SEXP_CDR(o1)) { - analyze(SEXP_CAR(o1), bc, i, e, params, fv, d); + analyze(SEXP_CAR(o1), bc, i, e, params, fv, sv, d); } /* push the operator onto the stack */ - analyze(SEXP_CAR(obj), bc, i, e, params, fv, d); + analyze(SEXP_CAR(obj), bc, i, e, params, fv, sv, d); /* make the call */ emit(bc, i, OP_CALL); @@ -1346,7 +1352,7 @@ sexp free_vars (env e, sexp formals, sexp obj, sexp fv) { void analyze_lambda (sexp name, sexp formals, sexp body, bytecode *bc, unsigned int *i, env e, - sexp params, sexp fv, unsigned int *d) { + sexp params, sexp fv, sexp sv, unsigned int *d) { sexp obj; sexp fv2 = free_vars(e, formals, body, SEXP_NULL), ls; env e2 = extend_env_closure(e, formals); @@ -1354,7 +1360,7 @@ void analyze_lambda (sexp name, sexp formals, sexp body, fprintf(stderr, "%d free-vars\n", length(fv2)); write_sexp(stderr, fv2); fprintf(stderr, "\n"); - obj = (sexp) compile(formals, body, e2, fv2, 0); + obj = (sexp) compile(formals, body, e2, fv2, sv, 0); emit(bc, i, OP_PUSH); emit_word(bc, i, (unsigned long) SEXP_UNDEF); emit(bc, i, OP_PUSH); @@ -1362,7 +1368,7 @@ void analyze_lambda (sexp name, sexp formals, sexp body, emit(bc, i, OP_MAKE_VECTOR); (*d)++; for (ls=fv2, k=0; SEXP_PAIRP(ls); ls=SEXP_CDR(ls), k++) { - analyze_var_ref(SEXP_CAR(ls), bc, i, e, params, fv, d); + analyze_var_ref(SEXP_CAR(ls), bc, i, e, params, fv, sv, d); emit(bc, i, OP_PUSH); emit_word(bc, i, (unsigned long) make_integer(k)); emit(bc, i, OP_STACK_REF); @@ -1562,13 +1568,13 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { return stack[top-1]; } -bytecode compile(sexp params, sexp obj, env e, sexp fv, int done_p) { +bytecode compile(sexp params, sexp obj, env e, sexp fv, sexp sv, int done_p) { bytecode bc = (bytecode) malloc(sizeof(struct bytecode)+INIT_BCODE_SIZE); unsigned int i = 0, d = 0; bc->tag = SEXP_BYTECODE; bc->len = INIT_BCODE_SIZE; fprintf(stderr, "analyzing\n"); - analyze(obj, &bc, &i, e, params, fv, &d); + analyze(obj, &bc, &i, e, params, fv, sv, &d); emit(&bc, &i, done_p ? OP_DONE : OP_RET); /* fprintf(stderr, "shrinking\n"); */ shrink_bcode(&bc, i); @@ -1578,7 +1584,7 @@ bytecode compile(sexp params, sexp obj, env e, sexp fv, int done_p) { } sexp eval_in_stack(sexp obj, env e, sexp* stack, unsigned int top) { - bytecode bc = compile(SEXP_NULL, obj, e, SEXP_NULL, 1); + bytecode bc = compile(SEXP_NULL, obj, e, SEXP_NULL, SEXP_NULL, 1); fprintf(stderr, "evaling\n"); return vm(bc, e, stack, top); } From 5993be47a3c3ff6b4927e1fa4302e4f3512cf2e9 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 2 Mar 2009 16:41:41 +0900 Subject: [PATCH 006/154] adding a dissassembler --- sexp.c | 149 +++++++++++++++++++++++++++++++++++++++++++++++++++------ 1 file changed, 135 insertions(+), 14 deletions(-) diff --git a/sexp.c b/sexp.c index 9c7c825f..e5b2bb13 100644 --- a/sexp.c +++ b/sexp.c @@ -231,6 +231,14 @@ int list_index (sexp ls, sexp elt) { return -1; } +sexp lset_diff(sexp a, sexp b) { + sexp res = SEXP_NULL; + for ( ; SEXP_PAIRP(a); a=SEXP_CDR(a)) + if (! list_index(b, SEXP_CAR(a)) >= 0) + res = cons(SEXP_CAR(a), res); + return res; +} + sexp reverse(sexp ls) { sexp res = SEXP_NULL; for ( ; SEXP_PAIRP(ls); ls=SEXP_CDR(ls)) @@ -914,8 +922,8 @@ enum opcode_names { OP_GLOBAL_REF, /* 3 */ OP_GLOBAL_SET, /* 4 */ OP_CLOSURE_REF, /* 5 */ - OP_CLOSURE_SET, - OP_VECTOR_REF, + OP_CLOSURE_SET, /* 6 */ + OP_VECTOR_REF, /* 7 */ OP_VECTOR_SET, /* 8 */ OP_MAKE_PROCEDURE, OP_MAKE_VECTOR, @@ -925,22 +933,32 @@ enum opcode_names { OP_SWAP, OP_CAR, OP_CDR, /* 10 */ + OP_SET_CAR, /* 11 */ + OP_SET_CDR, /* 12 */ OP_CONS, - OP_ADD, + OP_ADD, /* 14 */ OP_SUB, - OP_MUL, /* 14 */ + OP_MUL, /* 16 */ OP_DIV, - OP_MOD, + OP_MOD, /* 18 */ OP_NEG, - OP_INV, /* 18 */ + OP_INV, /* 1A */ OP_LT, - OP_CALL, + OP_CALL, /* 1C */ OP_JUMP_UNLESS, - OP_JUMP, /* 1C */ + OP_JUMP, /* 1E */ OP_RET, OP_DONE, }; +static const char* reverse_opcode_names[] = + {"NOOP", "STACK_REF", "STACK_SET", "GLOBAL_REF", "GLOBAL_SET", "CLOSURE_REF", + "CLOSURE_SET", "VECTOR_REF", "VECTOR_SET", "MAKE_PROCEDURE", "MAKE_VECTOR", + "PUSH", "DUP", "DROP", "SWAP", "CAR", "CDR", "SET_CAR", "SET_CDR", "CONS", + "ADD", "SUB", "MUL", "DIV", "MOD", "NEG", "INV", "LT", "CALL", + "JUMP_UNLESS", "JUMP", "RET", "DONE" + }; + typedef struct opcode { char tag; char op_class; @@ -968,6 +986,38 @@ static struct opcode opcodes[] = { {SEXP_OPCODE, OPC_CONSTRUCTOR, OP_MAKE_PROCEDURE, 2, 0, 0, 0, "make-procedure", 0, NULL}, }; +void disasm (bytecode bc) { + unsigned char *ip=bc->data, opcode; + loop: + opcode = *ip++; + fprintf(stderr, " %s ", reverse_opcode_names[opcode]); + switch (opcode) { + case OP_STACK_REF: + case OP_STACK_SET: + case OP_CLOSURE_REF: + case OP_CLOSURE_SET: + fprintf(stderr, "%d", (long) ((sexp*)ip)[0]); + ip += sizeof(sexp); + break; + case OP_GLOBAL_REF: + case OP_GLOBAL_SET: + case OP_CALL: + case OP_PUSH: + write_sexp(stderr, ((sexp*)ip)[0]); + ip += sizeof(sexp); + break; + case OP_JUMP: + case OP_JUMP_UNLESS: + fprintf(stderr, "%d", ip[0]); + ip++; + break; + } + fprintf(stderr, "\n"); + if ((! (opcode == OP_RET) || (opcode == OP_DONE)) + && (ip - bc->data < bc->len)) + goto loop; +} + sexp env_cell(env e, sexp key) { sexp ls, res=NULL; @@ -1167,7 +1217,6 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, bc, i, e, params, fv, sv, d); break; case CORE_DEFINE: - case CORE_SET: fprintf(stderr, "compiling global set: %p\n", SEXP_CADR(obj)); if ((((core_form)o1)->code == CORE_DEFINE) && SEXP_PAIRP(SEXP_CADR(obj))) { @@ -1186,6 +1235,13 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, (*d)++; emit_word(bc, i, (unsigned long) SEXP_UNDEF); break; + case CORE_SET: + analyze(SEXP_CADDR(obj), bc, i, e, params, fv, sv, d); + analyze_var_ref(SEXP_CADR(obj), bc, i, e, params, fv, SEXP_NULL, d); + emit(bc, i, OP_SET_CAR); + emit(bc, i, OP_PUSH); + (*d)++; + emit_word(bc, i, (unsigned long) SEXP_UNDEF); case CORE_BEGIN: for (o2 = SEXP_CDR(obj); SEXP_PAIRP(o2); o2 = SEXP_CDR(o2)) { analyze(SEXP_CAR(o2), bc, i, e, params, fv, sv, d); @@ -1272,7 +1328,7 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, errx(1, "invalid operator: %s", SEXP_CAR(obj)); } } else if (SEXP_SYMBOLP(obj)) { - analyze_var_ref (obj, bc, i, e, params, fv, sv, d); + analyze_var_ref(obj, bc, i, e, params, fv, sv, d); } else { fprintf(stderr, "push: %d\n", (unsigned long)obj); emit(bc, i, OP_PUSH); @@ -1303,6 +1359,9 @@ void analyze_var_ref (sexp obj, bytecode *bc, unsigned int *i, env e, emit_word(bc, i, (unsigned long) obj); (*d)++; } + if (list_index(sv, obj) >= 0) { + emit(bc, i, OP_CAR); + } } void analyze_app (sexp obj, bytecode *bc, unsigned int *i, @@ -1350,6 +1409,32 @@ sexp free_vars (env e, sexp formals, sexp obj, sexp fv) { } } +sexp set_vars (env e, sexp formals, sexp obj, sexp sv) { + sexp o1; + if (SEXP_NULLP(formals)) + return sv; + if (SEXP_PAIRP(obj)) { + if (SEXP_SYMBOLP(SEXP_CAR(obj))) { + if ((o1 = env_cell(e, SEXP_CAR(obj))) && SEXP_COREP(o1)) { + if (((core_form)SEXP_CDR(o1))->code == CORE_LAMBDA) { + formals = lset_diff(formals, SEXP_CADR(obj)); + return set_vars(e, formals, SEXP_CADDR(obj), sv); + } else if (((core_form)SEXP_CDR(o1))->code == CORE_SET + && (list_index(formals, SEXP_CADR(obj)) >= 0) + && ! (list_index(sv, SEXP_CADR(obj)) >= 0)) { + sv = cons(SEXP_CADR(obj), sv); + return set_vars(e, formals, SEXP_CADDR(obj), sv); + } + } + } + while (SEXP_PAIRP(obj)) { + sv = set_vars(e, formals, SEXP_CAR(obj), sv); + obj = SEXP_CDR(obj); + } + } + return sv; +} + void analyze_lambda (sexp name, sexp formals, sexp body, bytecode *bc, unsigned int *i, env e, sexp params, sexp fv, sexp sv, unsigned int *d) { @@ -1421,6 +1506,12 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { ip += sizeof(sexp); top++; break; + case OP_STACK_SET: + stack[top - (unsigned int) ((sexp*)ip)[0]] = stack[top-1]; + stack[top] = SEXP_UNDEF; + ip += sizeof(sexp); + top++; + break; case OP_CLOSURE_REF: fprintf(stderr, "closure-ref %d => ", ((sexp*)ip)[0]); fflush(stderr); @@ -1475,8 +1566,18 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { case OP_CDR: stack[top-1]=cdr(stack[top-1]); break; + case OP_SET_CAR: + set_car(stack[top-1], stack[top-2]); + stack[top-2]=SEXP_UNDEF; + top--; + break; + case OP_SET_CDR: + set_cdr(stack[top-1], stack[top-2]); + stack[top-2]=SEXP_UNDEF; + top--; + break; case OP_CONS: - stack[top-2]=cons(stack[top-2], stack[top-1]); + stack[top-2]=cons(stack[top-1], stack[top-2]); top--; break; case OP_ADD: @@ -1541,15 +1642,20 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { fprintf(stderr, "returning @ %d: ", top-1); fflush(stderr); write_sexp(stderr, stack[top-1]); - fprintf(stderr, "\n"); - /* print_stack(stack, top); */ + fprintf(stderr, "...\n"); + print_stack(stack, top); /* top-1 */ /* stack: args ... n ip result */ cp = stack[top-2]; + fprintf(stderr, "1\n"); ip = (unsigned char*) stack[top-3]; + fprintf(stderr, "2\n"); i = unbox_integer(stack[top-4]); + fprintf(stderr, "3 (i=%d)\n", i); stack[top-i-4] = stack[top-1]; + fprintf(stderr, "4\n"); top = top-i-3; + fprintf(stderr, "... done returning\n"); break; case OP_DONE: fprintf(stderr, "finally returning @ %d: ", top-1); @@ -1562,6 +1668,7 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { stack[top] = SEXP_ERROR; goto end_loop; } + fprintf(stderr, "looping\n"); goto loop; end_loop: @@ -1569,17 +1676,31 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { } bytecode compile(sexp params, sexp obj, env e, sexp fv, sexp sv, int done_p) { + unsigned int i = 0, j, d = 0; bytecode bc = (bytecode) malloc(sizeof(struct bytecode)+INIT_BCODE_SIZE); - unsigned int i = 0, d = 0; + sexp sv2 = set_vars(e, params, obj, SEXP_NULL), ls; bc->tag = SEXP_BYTECODE; bc->len = INIT_BCODE_SIZE; fprintf(stderr, "analyzing\n"); + for (ls=sv2; SEXP_PAIRP(ls); ls=SEXP_CDR(ls)) { + if ((j = list_index(sv2, SEXP_CAR(ls)) >= 0)) { + emit(&bc, &i, OP_STACK_REF); + emit_word(&bc, &i, j+3); + emit(&bc, &i, OP_PUSH); + emit_word(&bc, &i, (unsigned long) SEXP_NULL); + emit(&bc, &i, OP_CONS); + emit(&bc, &i, OP_STACK_SET); + emit_word(&bc, &i, j+4); + emit(&bc, &i, OP_DROP); + } + } analyze(obj, &bc, &i, e, params, fv, sv, &d); emit(&bc, &i, done_p ? OP_DONE : OP_RET); /* fprintf(stderr, "shrinking\n"); */ shrink_bcode(&bc, i); fprintf(stderr, "done compiling:\n"); print_bytecode(bc); + disasm(bc); return bc; } From a8a8372505c0f6e2050d19a3e8351ac26c2eab9a Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 3 Mar 2009 19:17:36 +0900 Subject: [PATCH 007/154] initial mutation support --- sexp.c | 76 ++++++++++++++++++++++++++++++++++++++++------------------ 1 file changed, 53 insertions(+), 23 deletions(-) diff --git a/sexp.c b/sexp.c index e5b2bb13..6a480dcb 100644 --- a/sexp.c +++ b/sexp.c @@ -269,6 +269,12 @@ sexp nreverse(sexp ls) { } } +sexp append(sexp a, sexp b) { + for (a=reverse(a); SEXP_PAIRP(a); a=SEXP_CDR(a)) + b = cons(SEXP_CAR(a), b); + return b; +} + sexp list(int count, ...) { sexp res = SEXP_NULL; int i; @@ -492,6 +498,12 @@ void write_sexp (FILE *out, sexp obj) { case SEXP_PROCEDURE: fprintf(out, "#"); break; + case SEXP_BYTECODE: + fprintf(out, "#"); + break; + case SEXP_ENV: + fprintf(out, "#"); + break; case SEXP_STRING: fprintf(out, "\""); /* FALLTHROUGH */ @@ -990,7 +1002,11 @@ void disasm (bytecode bc) { unsigned char *ip=bc->data, opcode; loop: opcode = *ip++; - fprintf(stderr, " %s ", reverse_opcode_names[opcode]); + if (opcode*sizeof(char*) < sizeof(reverse_opcode_names)) { + fprintf(stderr, " %s ", reverse_opcode_names[opcode]); + } else { + fprintf(stderr, " %d ", opcode); + } switch (opcode) { case OP_STACK_REF: case OP_STACK_SET: @@ -1213,7 +1229,7 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, switch (((core_form)o1)->code) { case CORE_LAMBDA: fprintf(stderr, ":: lambda\n"); - analyze_lambda(SEXP_FALSE, SEXP_CADR(obj), SEXP_CADDR(obj), + analyze_lambda(SEXP_FALSE, SEXP_CADR(obj), SEXP_CDDR(obj), bc, i, e, params, fv, sv, d); break; case CORE_DEFINE: @@ -1222,7 +1238,7 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, && SEXP_PAIRP(SEXP_CADR(obj))) { analyze_lambda(SEXP_CAR(SEXP_CADR(obj)), SEXP_CDR(SEXP_CADR(obj)), - SEXP_CADDR(obj), + SEXP_CDDR(obj), bc, i, e, params, fv, sv, d); } else { analyze(SEXP_CADDR(obj), bc, i, e, params, fv, sv, d); @@ -1236,15 +1252,17 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, emit_word(bc, i, (unsigned long) SEXP_UNDEF); break; case CORE_SET: + fprintf(stderr, "set!: "); write_sexp(stderr, SEXP_CADR(obj)); + fprintf(stderr, " sv: "); write_sexp(stderr, sv); + fprintf(stderr, "\n"); analyze(SEXP_CADDR(obj), bc, i, e, params, fv, sv, d); analyze_var_ref(SEXP_CADR(obj), bc, i, e, params, fv, SEXP_NULL, d); emit(bc, i, OP_SET_CAR); - emit(bc, i, OP_PUSH); - (*d)++; - emit_word(bc, i, (unsigned long) SEXP_UNDEF); + break; case CORE_BEGIN: for (o2 = SEXP_CDR(obj); SEXP_PAIRP(o2); o2 = SEXP_CDR(o2)) { analyze(SEXP_CAR(o2), bc, i, e, params, fv, sv, d); + if (SEXP_PAIRP(SEXP_CDR(o2))) emit(bc, i, OP_DROP); } break; case CORE_IF: @@ -1342,7 +1360,9 @@ void analyze_var_ref (sexp obj, bytecode *bc, unsigned int *i, env e, int tmp; /* variable reference */ /* cell = env_cell(e, obj); */ - fprintf(stderr, "symbol lookup, param length: %d\n", length(params)); + fprintf(stderr, "symbol lookup, param length: %d sv: ", length(params)); + write_sexp(stderr, sv); + fprintf(stderr, "\n"); if ((tmp = list_index(params, obj)) >= 0) { fprintf(stderr, "compiling local ref: %p => %d (d = %d)\n", obj, tmp, *d); emit(bc, i, OP_STACK_REF); @@ -1360,6 +1380,7 @@ void analyze_var_ref (sexp obj, bytecode *bc, unsigned int *i, env e, (*d)++; } if (list_index(sv, obj) >= 0) { + fprintf(stderr, "mutable variables, fetching CAR\n"); emit(bc, i, OP_CAR); } } @@ -1410,20 +1431,23 @@ sexp free_vars (env e, sexp formals, sexp obj, sexp fv) { } sexp set_vars (env e, sexp formals, sexp obj, sexp sv) { - sexp o1; + sexp tmp; if (SEXP_NULLP(formals)) return sv; if (SEXP_PAIRP(obj)) { if (SEXP_SYMBOLP(SEXP_CAR(obj))) { - if ((o1 = env_cell(e, SEXP_CAR(obj))) && SEXP_COREP(o1)) { - if (((core_form)SEXP_CDR(o1))->code == CORE_LAMBDA) { + if ((tmp = env_cell(e, SEXP_CAR(obj))) && SEXP_COREP(SEXP_CDR(tmp))) { + if (((core_form)SEXP_CDR(tmp))->code == CORE_LAMBDA) { formals = lset_diff(formals, SEXP_CADR(obj)); return set_vars(e, formals, SEXP_CADDR(obj), sv); - } else if (((core_form)SEXP_CDR(o1))->code == CORE_SET - && (list_index(formals, SEXP_CADR(obj)) >= 0) - && ! (list_index(sv, SEXP_CADR(obj)) >= 0)) { - sv = cons(SEXP_CADR(obj), sv); - return set_vars(e, formals, SEXP_CADDR(obj), sv); + } else if (((core_form)SEXP_CDR(tmp))->code == CORE_SET) { + if ((list_index(formals, SEXP_CADR(obj)) >= 0) + && ! (list_index(sv, SEXP_CADR(obj)) >= 0)) { + fprintf(stderr, "found set! "); write_sexp(stderr, SEXP_CADR(obj)); + fprintf(stderr, "\n"); + sv = cons(SEXP_CADR(obj), sv); + return set_vars(e, formals, SEXP_CADDR(obj), sv); + } } } } @@ -1453,7 +1477,7 @@ void analyze_lambda (sexp name, sexp formals, sexp body, emit(bc, i, OP_MAKE_VECTOR); (*d)++; for (ls=fv2, k=0; SEXP_PAIRP(ls); ls=SEXP_CDR(ls), k++) { - analyze_var_ref(SEXP_CAR(ls), bc, i, e, params, fv, sv, d); + analyze_var_ref(SEXP_CAR(ls), bc, i, e, params, fv, SEXP_NULL, d); emit(bc, i, OP_PUSH); emit_word(bc, i, (unsigned long) make_integer(k)); emit(bc, i, OP_STACK_REF); @@ -1508,9 +1532,8 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { break; case OP_STACK_SET: stack[top - (unsigned int) ((sexp*)ip)[0]] = stack[top-1]; - stack[top] = SEXP_UNDEF; + stack[top-1] = SEXP_UNDEF; ip += sizeof(sexp); - top++; break; case OP_CLOSURE_REF: fprintf(stderr, "closure-ref %d => ", ((sexp*)ip)[0]); @@ -1679,22 +1702,29 @@ bytecode compile(sexp params, sexp obj, env e, sexp fv, sexp sv, int done_p) { unsigned int i = 0, j, d = 0; bytecode bc = (bytecode) malloc(sizeof(struct bytecode)+INIT_BCODE_SIZE); sexp sv2 = set_vars(e, params, obj, SEXP_NULL), ls; + fprintf(stderr, "set-vars: "); write_sexp(stderr, sv2); fprintf(stderr, "\n"); bc->tag = SEXP_BYTECODE; bc->len = INIT_BCODE_SIZE; fprintf(stderr, "analyzing\n"); - for (ls=sv2; SEXP_PAIRP(ls); ls=SEXP_CDR(ls)) { + for (ls=params; SEXP_PAIRP(ls); ls=SEXP_CDR(ls)) { if ((j = list_index(sv2, SEXP_CAR(ls)) >= 0)) { - emit(&bc, &i, OP_STACK_REF); - emit_word(&bc, &i, j+3); + fprintf(stderr, "consing mutable var\n"); emit(&bc, &i, OP_PUSH); emit_word(&bc, &i, (unsigned long) SEXP_NULL); + emit(&bc, &i, OP_STACK_REF); + emit_word(&bc, &i, j+3); emit(&bc, &i, OP_CONS); emit(&bc, &i, OP_STACK_SET); emit_word(&bc, &i, j+4); emit(&bc, &i, OP_DROP); } } - analyze(obj, &bc, &i, e, params, fv, sv, &d); + sv = append(sv2, sv); + for ( ; SEXP_PAIRP(obj); obj=SEXP_CDR(obj)) { + fprintf(stderr, "loop: "); write_sexp(stderr, obj); fprintf(stderr, "\n"); + analyze(SEXP_CAR(obj), &bc, &i, e, params, fv, sv, &d); + if (SEXP_PAIRP(SEXP_CDR(obj))) emit(&bc, &i, OP_DROP); + } emit(&bc, &i, done_p ? OP_DONE : OP_RET); /* fprintf(stderr, "shrinking\n"); */ shrink_bcode(&bc, i); @@ -1705,7 +1735,7 @@ bytecode compile(sexp params, sexp obj, env e, sexp fv, sexp sv, int done_p) { } sexp eval_in_stack(sexp obj, env e, sexp* stack, unsigned int top) { - bytecode bc = compile(SEXP_NULL, obj, e, SEXP_NULL, SEXP_NULL, 1); + bytecode bc = compile(SEXP_NULL, cons(obj, SEXP_NULL), e, SEXP_NULL, SEXP_NULL, 1); fprintf(stderr, "evaling\n"); return vm(bc, e, stack, top); } From b3a0c52889137bcd62fbee66281bbc96f56a8784 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 3 Mar 2009 21:29:04 +0900 Subject: [PATCH 008/154] splitting into multiple files --- Makefile | 26 ++ config.h | 8 + debug.c | 82 ++++ eval.c | 719 ++++++++++++++++++++++++++++++ eval.h | 119 +++++ sexp.c | 1309 +++++------------------------------------------------- sexp.h | 195 ++++++++ 7 files changed, 1261 insertions(+), 1197 deletions(-) create mode 100644 Makefile create mode 100644 config.h create mode 100644 debug.c create mode 100644 eval.c create mode 100644 eval.h create mode 100644 sexp.h diff --git a/Makefile b/Makefile new file mode 100644 index 00000000..d352a6d5 --- /dev/null +++ b/Makefile @@ -0,0 +1,26 @@ + +.PHONY: all doc dist clean cleaner test install uninstall + +all: chibi-scheme + +GC_OBJ=./gc/gc.a + +$GC_OBJ: ./gc/alloc.c + cd gc && make test + +sexp.o: sexp.c sexp.h + gcc -c -g -Os -o $@ $< + +eval.o: eval.c eval.h sexp.h + gcc -c -g -Os -o $@ $< + +chibi-scheme: sexp.o eval.o $(GC_OBJ) + gcc -g -Os -o $@ $^ + +clean: + rm -f *.o + +cleaner: clean + rm -f chibi-scheme + rm -rf *.dSYM + diff --git a/config.h b/config.h new file mode 100644 index 00000000..bb962e65 --- /dev/null +++ b/config.h @@ -0,0 +1,8 @@ +/* config.h -- general configuration */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#define USE_BOEHM 1 +#define USE_HUFF_SYMS 1 +#define USE_DEBUG 1 + diff --git a/debug.c b/debug.c new file mode 100644 index 00000000..cded6223 --- /dev/null +++ b/debug.c @@ -0,0 +1,82 @@ +/* debug.c -- optional debugging utilities */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +static const char* reverse_opcode_names[] = + {"NOOP", "STACK_REF", "STACK_SET", "GLOBAL_REF", "GLOBAL_SET", "CLOSURE_REF", + "CLOSURE_SET", "VECTOR_REF", "VECTOR_SET", "MAKE_PROCEDURE", "MAKE_VECTOR", + "PUSH", "DUP", "DROP", "SWAP", "CAR", "CDR", "SET_CAR", "SET_CDR", "CONS", + "ADD", "SUB", "MUL", "DIV", "MOD", "NEG", "INV", "LT", "CALL", + "JUMP_UNLESS", "JUMP", "RET", "DONE" + }; + +void disasm (bytecode bc) { + unsigned char *ip=bc->data, opcode; + loop: + opcode = *ip++; + if (opcode*sizeof(char*) < sizeof(reverse_opcode_names)) { + fprintf(stderr, " %s ", reverse_opcode_names[opcode]); + } else { + fprintf(stderr, " %d ", opcode); + } + switch (opcode) { + case OP_STACK_REF: + case OP_STACK_SET: + case OP_CLOSURE_REF: + case OP_CLOSURE_SET: + fprintf(stderr, "%d", (long) ((sexp*)ip)[0]); + ip += sizeof(sexp); + break; + case OP_GLOBAL_REF: + case OP_GLOBAL_SET: + case OP_CALL: + case OP_PUSH: + write_sexp(stderr, ((sexp*)ip)[0]); + ip += sizeof(sexp); + break; + case OP_JUMP: + case OP_JUMP_UNLESS: + fprintf(stderr, "%d", ip[0]); + ip++; + break; + } + fprintf(stderr, "\n"); + if ((! (opcode == OP_RET) || (opcode == OP_DONE)) + && (ip - bc->data < bc->len)) + goto loop; +} + +void print_bytecode (bytecode bc) { + int i; + fprintf(stderr, "bytecode @ %p, data @ %p, length = %d\n", + bc, bc->data, bc->len); + for (i=0; i+16 < bc->len; i+=8) { + fprintf(stderr, "%02x: %02x %02x %02x %02x %02x %02x %02x %02x ", i, + bc->data[i], bc->data[i+1], bc->data[i+2], bc->data[i+3], + bc->data[i+4], bc->data[i+5], bc->data[i+6], bc->data[i+7]); + i += 8; + fprintf(stderr, "%02x %02x %02x %02x %02x %02x %02x %02x\n", + bc->data[i], bc->data[i+1], bc->data[i+2], bc->data[i+3], + bc->data[i+4], bc->data[i+5], bc->data[i+6], bc->data[i+7]); + } + if (i != bc->len) { + fprintf(stderr, "%02x:", i); + for ( ; i < bc->len; i++) { + if ((i % 8) == 0 && (i % 16) != 0) + fprintf(stderr, " "); + fprintf(stderr, " %02x", bc->data[i]); + } + fprintf(stderr, "\n"); + } +} + +void print_stack (sexp *stack, int top) { + int i; + for (i=0; ibindings; SEXP_PAIRP(ls); ls=SEXP_CDR(ls)) { + if (SEXP_CAAR(ls) == key) { + res = SEXP_CAR(ls); + break; + } + } + e = e->parent; + } while (e && ! res); + + return res; +} + +int env_global_p (env e, sexp id) { + while (e->parent) { + if (assq(id, e->bindings) != SEXP_FALSE) + return 0; + else + e = e->parent; + } + return 1; +} + +void env_define(env e, sexp key, sexp value) { + sexp cell = env_cell(e, key); + if (cell) { + SEXP_CDR(cell) = value; + } else { + e->bindings = cons(cons(key, value), e->bindings); + } +} + +env extend_env_closure (env e, sexp fv) { + int i; + env e2 = (env) malloc(sizeof(struct env)); + e2->tag = SEXP_ENV; + e2->parent = e; + e2->bindings = SEXP_NULL; + for (i=0; SEXP_PAIRP(fv); fv = SEXP_CDR(fv), i++) { + e2->bindings = cons(cons(SEXP_CAR(fv), make_integer(i)), e2->bindings); + } + return e2; +} + +env make_standard_env() { + int i; + env e = (env) malloc(sizeof(struct env)); + e->tag = SEXP_ENV; + e->parent = NULL; + e->bindings = SEXP_NULL; + for (i=0; i<(sizeof(core_forms)/sizeof(struct core_form)); i++) { + env_define(e, intern(core_forms[i].name), (sexp)(&core_forms[i])); + } + for (i=0; i<(sizeof(opcodes)/sizeof(struct opcode)); i++) { + env_define(e, intern(opcodes[i].name), (sexp)(&opcodes[i])); + } + return e; +} + +/************************* bytecode utilities ***************************/ + +void shrink_bcode(bytecode *bc, unsigned int i) { + bytecode tmp; + if ((*bc)->len != i) { + fprintf(stderr, "shrinking to %d\n", i); + tmp = (bytecode) malloc(sizeof(struct bytecode) + i); + tmp->tag = SEXP_BYTECODE; + tmp->len = i; + memcpy(tmp->data, (*bc)->data, i); + SEXP_FREE(*bc); + *bc = tmp; + } +} + +void emit(bytecode *bc, unsigned int *i, char c) { + bytecode tmp; + if ((*bc)->len < (*i)+1) { + fprintf(stderr, "expanding (%d < %d)\n", (*bc)->len, (*i)+1); + tmp = (bytecode) malloc(sizeof(unsigned int) + (*bc)->len*2); + tmp->len = (*bc)->len*2; + memcpy(tmp->data, (*bc)->data, (*bc)->len); + SEXP_FREE(*bc); + *bc = tmp; + } + (*bc)->data[(*i)++] = c; +} + +void emit_word(bytecode *bc, unsigned int *i, unsigned long val) { + bytecode tmp; + if ((*bc)->len < (*i)+4) { + tmp = (bytecode) malloc(sizeof(unsigned int) + (*bc)->len*2); + tmp->len = (*bc)->len*2; + memcpy(tmp->data, (*bc)->data, (*bc)->len); + SEXP_FREE(*bc); + *bc = tmp; + } + *((unsigned long*)(&((*bc)->data[*i]))) = val; + *i += sizeof(unsigned long); +} + +sexp make_procedure(sexp bc, sexp vars) { + sexp proc = SEXP_NEW(); + if (! proc) return SEXP_ERROR; + proc->tag = SEXP_PROCEDURE; + proc->data1 = (void*) bc; + proc->data2 = (void*) vars; + return proc; +} + +/************************* the compiler ***************************/ + +void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, + sexp params, sexp fv, sexp sv, unsigned int *d) { + int tmp1, tmp2; + env e2 = e; + sexp o1, o2, cell; + + if (SEXP_PAIRP(obj)) { + /* fprintf(stderr, ":: pair\n"); */ + if (SEXP_SYMBOLP(SEXP_CAR(obj))) { + fprintf(stderr, ":: symbol application\n"); + o1 = env_cell(e, SEXP_CAR(obj)); + /* fprintf(stderr, ":: => %p\n", o1); */ + if (! o1) + errx(1, "unknown operator: %s", SEXP_CAR(obj)); + o1 = SEXP_CDR(o1); + /* fprintf(stderr, ":: => %p\n", o1); */ + if (SEXP_COREP(o1)) { + /* core form */ + fprintf(stderr, ":: core form\n"); + switch (((core_form)o1)->code) { + case CORE_LAMBDA: + fprintf(stderr, ":: lambda\n"); + analyze_lambda(SEXP_FALSE, SEXP_CADR(obj), SEXP_CDDR(obj), + bc, i, e, params, fv, sv, d); + break; + case CORE_DEFINE: + fprintf(stderr, "compiling global set: %p\n", SEXP_CADR(obj)); + if ((((core_form)o1)->code == CORE_DEFINE) + && SEXP_PAIRP(SEXP_CADR(obj))) { + analyze_lambda(SEXP_CAR(SEXP_CADR(obj)), + SEXP_CDR(SEXP_CADR(obj)), + SEXP_CDDR(obj), + bc, i, e, params, fv, sv, d); + } else { + analyze(SEXP_CADDR(obj), bc, i, e, params, fv, sv, d); + } + emit(bc, i, OP_GLOBAL_SET); + emit_word(bc, i, (unsigned long) (SEXP_PAIRP(SEXP_CADR(obj)) + ? SEXP_CAR(SEXP_CADR(obj)) + : SEXP_CADR(obj))); + emit(bc, i, OP_PUSH); + (*d)++; + emit_word(bc, i, (unsigned long) SEXP_UNDEF); + break; + case CORE_SET: + fprintf(stderr, "set!: "); write_sexp(stderr, SEXP_CADR(obj)); + fprintf(stderr, " sv: "); write_sexp(stderr, sv); + fprintf(stderr, "\n"); + analyze(SEXP_CADDR(obj), bc, i, e, params, fv, sv, d); + analyze_var_ref(SEXP_CADR(obj), bc, i, e, params, fv, SEXP_NULL, d); + emit(bc, i, OP_SET_CAR); + break; + case CORE_BEGIN: + for (o2 = SEXP_CDR(obj); SEXP_PAIRP(o2); o2 = SEXP_CDR(o2)) { + analyze(SEXP_CAR(o2), bc, i, e, params, fv, sv, d); + if (SEXP_PAIRP(SEXP_CDR(o2))) emit(bc, i, OP_DROP); + } + break; + case CORE_IF: + fprintf(stderr, "test clause: %d\n", *i); + analyze(SEXP_CADR(obj), bc, i, e, params, fv, sv, d); + emit(bc, i, OP_JUMP_UNLESS); /* jumps if test fails */ + tmp1 = *i; + emit(bc, i, 0); + fprintf(stderr, "pass clause: %d\n", *i); + analyze(SEXP_CADDR(obj), bc, i, e, params, fv, sv, d); + emit(bc, i, OP_JUMP); + tmp2 = *i; + emit(bc, i, 0); + ((signed char*) (*bc)->data)[tmp1] = (*i)-tmp1-1; /* patch */ + fprintf(stderr, "fail clause: %d\n", *i); + if (SEXP_PAIRP(SEXP_CDDDR(obj))) { + analyze(SEXP_CADDDR(obj), bc, i, e, params, fv, sv, d); + } else { + emit(bc, i, OP_PUSH); + (*d)++; + emit_word(bc, i, (unsigned long) SEXP_UNDEF); + } + ((signed char*) (*bc)->data)[tmp2] = (*i)-tmp2-1; /* patch */ + break; + case CORE_QUOTE: + emit(bc, i, OP_PUSH); + (*d)++; + emit_word(bc, i, (unsigned long)SEXP_CADR(obj)); + break; + default: + errx(1, "unknown core form: %s", ((core_form)o1)->code); + } + } else if (SEXP_OPCODEP(o1)) { + fprintf(stderr, ":: opcode\n"); + /* direct opcode */ + /* verify arity */ + switch (((opcode)o1)->op_class) { + case OPC_TYPE_PREDICATE: + case OPC_PREDICATE: + case OPC_ARITHMETIC: + case OPC_ARITHMETIC_INV: + case OPC_ARITHMETIC_CMP: + if (SEXP_NULLP(SEXP_CDR(obj))) { + errx(1, "unknown opcode class: %d", ((opcode)o1)->op_class); + } else if (SEXP_NULLP(SEXP_CDDR(obj))) { + if (((opcode)o1)->op_class == OPC_ARITHMETIC_INV) { + analyze(SEXP_CADR(obj), bc, i, e, params, fv, sv, d); + emit(bc, i, ((opcode)o1)->op_inverse); + } else { + analyze(SEXP_CADR(obj), bc, i, e, params, fv, sv, d); + } + } else { + /* fprintf(stderr, ":: class: %d\n", ((opcode)o1)->op_class); */ + for (o2 = reverse(SEXP_CDR(obj)); SEXP_PAIRP(o2); o2 = SEXP_CDR(o2)) { + /* fprintf(stderr, ":: arg: %d\n", SEXP_CAR(o2)); */ + analyze(SEXP_CAR(o2), bc, i, e, params, fv, sv, d); + } + fprintf(stderr, ":: name: %d\n", ((opcode)o1)->op_name); + emit(bc, i, ((opcode)o1)->op_name); + (*d) -= length(SEXP_CDDR(obj)); + } + break; + default: + errx(1, "unknown opcode class: %d", ((opcode)o1)->op_class); + } + } else { + /* function call */ + analyze_app(obj, bc, i, e, params, fv, sv, d); + } + } else if (SEXP_PAIRP(SEXP_CAR(obj))) { + o2 = env_cell(e, SEXP_CAAR(obj)); +/* if (o2 */ +/* && SEXP_COREP(SEXP_CDR(o2)) */ +/* && (((core_form)SEXP_CDR(o2))->code == CORE_LAMBDA)) { */ +/* /\* let *\/ */ +/* } else { */ + /* computed application */ + analyze_app(obj, bc, i, e, params, fv, sv, d); +/* } */ + } else { + errx(1, "invalid operator: %s", SEXP_CAR(obj)); + } + } else if (SEXP_SYMBOLP(obj)) { + analyze_var_ref(obj, bc, i, e, params, fv, sv, d); + } else { + fprintf(stderr, "push: %d\n", (unsigned long)obj); + emit(bc, i, OP_PUSH); + emit_word(bc, i, (unsigned long)obj); + (*d)++; + } +} + +void analyze_var_ref (sexp obj, bytecode *bc, unsigned int *i, env e, + sexp params, sexp fv, sexp sv, unsigned int *d) { + int tmp; + fprintf(stderr, "symbol lookup, param length: %d sv: ", length(params)); + write_sexp(stderr, sv); + fprintf(stderr, "\n"); + if ((tmp = list_index(params, obj)) >= 0) { + fprintf(stderr, "compiling local ref: %p => %d (d = %d)\n", obj, tmp, *d); + emit(bc, i, OP_STACK_REF); + emit_word(bc, i, tmp + *d + 4); + (*d)++; + } else if ((tmp = list_index(fv, obj)) >= 0) { + fprintf(stderr, "compiling closure ref: %p => %d\n", obj, tmp); + emit(bc, i, OP_CLOSURE_REF); + emit_word(bc, i, tmp); + (*d)++; + } else { + fprintf(stderr, "compiling global ref: %p\n", obj); + emit(bc, i, OP_GLOBAL_REF); + emit_word(bc, i, (unsigned long) obj); + (*d)++; + } + if (list_index(sv, obj) >= 0) { + fprintf(stderr, "mutable variables, fetching CAR\n"); + emit(bc, i, OP_CAR); + } +} + +void analyze_app (sexp obj, bytecode *bc, unsigned int *i, + env e, sexp params, sexp fv, sexp sv, unsigned int *d) { + sexp o1; + unsigned long len = length(SEXP_CDR(obj)); + + /* push the arguments onto the stack */ + for (o1 = reverse(SEXP_CDR(obj)); SEXP_PAIRP(o1); o1 = SEXP_CDR(o1)) { + analyze(SEXP_CAR(o1), bc, i, e, params, fv, sv, d); + } + + /* push the operator onto the stack */ + analyze(SEXP_CAR(obj), bc, i, e, params, fv, sv, d); + + /* make the call */ + emit(bc, i, OP_CALL); + emit_word(bc, i, (unsigned long) make_integer(len)); +} + +sexp free_vars (env e, sexp formals, sexp obj, sexp fv) { + sexp o1; + if (SEXP_SYMBOLP(obj)) { + if (env_global_p(e, obj) + || (list_index(formals, obj) >= 0) + || (list_index(fv, obj) >= 0)) + return fv; + else + return cons(obj, fv); + } else if (SEXP_PAIRP(obj)) { + if (SEXP_SYMBOLP(SEXP_CAR(obj))) { + if ((o1 = env_cell(e, SEXP_CAR(obj))) + && SEXP_COREP(o1) + && (((core_form)SEXP_CDR(o1))->code == CORE_LAMBDA)) { + return free_vars(e, SEXP_CADR(obj), SEXP_CADDR(obj), fv); + } + } + while (SEXP_PAIRP(obj)) { + fv = free_vars(e, formals, SEXP_CAR(obj), fv); + obj = SEXP_CDR(obj); + } + return fv; + } else { + return fv; + } +} + +sexp set_vars (env e, sexp formals, sexp obj, sexp sv) { + sexp tmp; + if (SEXP_NULLP(formals)) + return sv; + if (SEXP_PAIRP(obj)) { + if (SEXP_SYMBOLP(SEXP_CAR(obj))) { + if ((tmp = env_cell(e, SEXP_CAR(obj))) && SEXP_COREP(SEXP_CDR(tmp))) { + if (((core_form)SEXP_CDR(tmp))->code == CORE_LAMBDA) { + formals = lset_diff(formals, SEXP_CADR(obj)); + return set_vars(e, formals, SEXP_CADDR(obj), sv); + } else if (((core_form)SEXP_CDR(tmp))->code == CORE_SET) { + if ((list_index(formals, SEXP_CADR(obj)) >= 0) + && ! (list_index(sv, SEXP_CADR(obj)) >= 0)) { + fprintf(stderr, "found set! "); write_sexp(stderr, SEXP_CADR(obj)); + fprintf(stderr, "\n"); + sv = cons(SEXP_CADR(obj), sv); + return set_vars(e, formals, SEXP_CADDR(obj), sv); + } + } + } + } + while (SEXP_PAIRP(obj)) { + sv = set_vars(e, formals, SEXP_CAR(obj), sv); + obj = SEXP_CDR(obj); + } + } + return sv; +} + +void analyze_lambda (sexp name, sexp formals, sexp body, + bytecode *bc, unsigned int *i, env e, + sexp params, sexp fv, sexp sv, unsigned int *d) { + sexp obj; + sexp fv2 = free_vars(e, formals, body, SEXP_NULL), ls; + env e2 = extend_env_closure(e, formals); + int k; + fprintf(stderr, "%d free-vars\n", length(fv2)); + write_sexp(stderr, fv2); + fprintf(stderr, "\n"); + obj = (sexp) compile(formals, body, e2, fv2, sv, 0); + emit(bc, i, OP_PUSH); + emit_word(bc, i, (unsigned long) SEXP_UNDEF); + emit(bc, i, OP_PUSH); + emit_word(bc, i, (unsigned long) make_integer(length(fv2))); + emit(bc, i, OP_MAKE_VECTOR); + (*d)++; + for (ls=fv2, k=0; SEXP_PAIRP(ls); ls=SEXP_CDR(ls), k++) { + analyze_var_ref(SEXP_CAR(ls), bc, i, e, params, fv, SEXP_NULL, d); + emit(bc, i, OP_PUSH); + emit_word(bc, i, (unsigned long) make_integer(k)); + emit(bc, i, OP_STACK_REF); + emit_word(bc, i, 3); + emit(bc, i, OP_VECTOR_SET); + emit(bc, i, OP_DROP); + (*d)--; + } + emit(bc, i, OP_PUSH); + emit_word(bc, i, (unsigned long) obj); + emit(bc, i, OP_MAKE_PROCEDURE); +} + +bytecode compile(sexp params, sexp obj, env e, sexp fv, sexp sv, int done_p) { + unsigned int i = 0, j, d = 0; + bytecode bc = (bytecode) malloc(sizeof(struct bytecode)+INIT_BCODE_SIZE); + sexp sv2 = set_vars(e, params, obj, SEXP_NULL), ls; + fprintf(stderr, "set-vars: "); write_sexp(stderr, sv2); fprintf(stderr, "\n"); + bc->tag = SEXP_BYTECODE; + bc->len = INIT_BCODE_SIZE; + fprintf(stderr, "analyzing\n"); + for (ls=params; SEXP_PAIRP(ls); ls=SEXP_CDR(ls)) { + if ((j = list_index(sv2, SEXP_CAR(ls)) >= 0)) { + fprintf(stderr, "consing mutable var\n"); + emit(&bc, &i, OP_PUSH); + emit_word(&bc, &i, (unsigned long) SEXP_NULL); + emit(&bc, &i, OP_STACK_REF); + emit_word(&bc, &i, j+3); + emit(&bc, &i, OP_CONS); + emit(&bc, &i, OP_STACK_SET); + emit_word(&bc, &i, j+4); + emit(&bc, &i, OP_DROP); + } + } + sv = append(sv2, sv); + for ( ; SEXP_PAIRP(obj); obj=SEXP_CDR(obj)) { + fprintf(stderr, "loop: "); write_sexp(stderr, obj); fprintf(stderr, "\n"); + analyze(SEXP_CAR(obj), &bc, &i, e, params, fv, sv, &d); + if (SEXP_PAIRP(SEXP_CDR(obj))) emit(&bc, &i, OP_DROP); + } + emit(&bc, &i, done_p ? OP_DONE : OP_RET); + /* fprintf(stderr, "shrinking\n"); */ + shrink_bcode(&bc, i); + fprintf(stderr, "done compiling:\n"); + print_bytecode(bc); + disasm(bc); + return bc; +} + +/*********************** the virtual machine **************************/ + +sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { + unsigned char *ip=bc->data; + sexp cp, tmp; + int i; + + loop: + /* fprintf(stderr, "opcode: %d, ip: %d\n", *ip, ip); */ + /* print_bytecode(bc); */ + switch (*ip++) { + case OP_NOOP: + fprintf(stderr, "noop\n"); + break; + case OP_GLOBAL_REF: + fprintf(stderr, "global ref: ip: %p => %p: ", ip, ((sexp*)ip)[0]); + fflush(stderr); + write_sexp(stderr, ((sexp*)ip)[0]); + fprintf(stderr, "\n"); + tmp = env_cell(e, ((sexp*)ip)[0]); + stack[top++]=SEXP_CDR(tmp); + ip += sizeof(sexp); + break; + case OP_GLOBAL_SET: + fprintf(stderr, "global set: %p: ", ((sexp*)ip)[0]); + fflush(stderr); + write_sexp(stderr, ((sexp*)ip)[0]); + fprintf(stderr, "\n"); + env_define(e, ((sexp*)ip)[0], stack[--top]); + ip += sizeof(sexp); + break; + case OP_STACK_REF: + fprintf(stderr, "stack ref: ip=%p, %d - %d => ", + ip, top, (unsigned long) ((sexp*)ip)[0]); + fflush(stderr); + write_sexp(stderr, stack[top - (unsigned int) ((sexp*)ip)[0]]); + fprintf(stderr, "\n"); + stack[top] = stack[top - (unsigned int) ((sexp*)ip)[0]]; + ip += sizeof(sexp); + top++; + break; + case OP_STACK_SET: + stack[top - (unsigned int) ((sexp*)ip)[0]] = stack[top-1]; + stack[top-1] = SEXP_UNDEF; + ip += sizeof(sexp); + break; + case OP_CLOSURE_REF: + fprintf(stderr, "closure-ref %d => ", ((sexp*)ip)[0]); + fflush(stderr); + write_sexp(stderr, vector_ref(cp,((sexp*)ip)[0])); + fprintf(stderr, "\n"); + stack[top++]=vector_ref(cp,((sexp*)ip)[0]); + ip += sizeof(sexp); + break; + case OP_VECTOR_REF: + stack[top-2]=vector_ref(stack[top-1], stack[top-2]); + top--; + break; + case OP_VECTOR_SET: + fprintf(stderr, "vector-set! %p %d => ", stack[top-1], unbox_integer(stack[top-2])); + write_sexp(stderr, stack[top-3]); + fprintf(stderr, "\n"); + vector_set(stack[top-1], stack[top-2], stack[top-3]); + stack[top-3]=SEXP_UNDEF; + top-=2; + break; + case OP_MAKE_PROCEDURE: + stack[top-2]=make_procedure(stack[top-1], stack[top-2]); + top--; + break; + case OP_MAKE_VECTOR: + stack[top-2]=make_vector(unbox_integer(stack[top-1]), stack[top-2]); + top--; + break; + case OP_PUSH: + /* fprintf(stderr, " (push)\n"); */ + stack[top++]=((sexp*)ip)[0]; + ip += sizeof(sexp); + break; + case OP_DUP: + stack[top]=stack[top-1]; + top++; + break; + case OP_DROP: + top--; + break; + case OP_SWAP: + tmp = stack[top-2]; + stack[top-2]=stack[top-1]; + stack[top-1]=tmp; + break; + case OP_CAR: + stack[top-1]=car(stack[top-1]); + break; + case OP_CDR: + stack[top-1]=cdr(stack[top-1]); + break; + case OP_SET_CAR: + set_car(stack[top-1], stack[top-2]); + stack[top-2]=SEXP_UNDEF; + top--; + break; + case OP_SET_CDR: + set_cdr(stack[top-1], stack[top-2]); + stack[top-2]=SEXP_UNDEF; + top--; + break; + case OP_CONS: + stack[top-2]=cons(stack[top-1], stack[top-2]); + top--; + break; + case OP_ADD: + fprintf(stderr, "OP_ADD %d %d\n", stack[top-1], stack[top-2]); + stack[top-2]=sexp_add(stack[top-1],stack[top-2]); + top--; + break; + case OP_SUB: + stack[top-2]=sexp_sub(stack[top-1],stack[top-2]); + top--; + break; + case OP_MUL: + stack[top-2]=sexp_mul(stack[top-2],stack[top-1]); + top--; + break; + case OP_DIV: + stack[top-2]=sexp_div(stack[top-2],stack[top-1]); + top--; + break; + case OP_MOD: + stack[top-2]=sexp_mod(stack[top-2],stack[top-1]); + top--; + break; + case OP_LT: + stack[top-2]=((stack[top-2] < stack[top-1]) ? SEXP_TRUE : SEXP_FALSE); + top--; + break; + case OP_CALL: + fprintf(stderr, "CALL\n"); + i = (unsigned long) ((sexp*)ip)[0]; + tmp = stack[top-1]; + if (! SEXP_PROCEDUREP(tmp)) + errx(2, "non-procedure application: %p", tmp); + stack[top-1] = (sexp) i; + stack[top] = (sexp) (ip+4); + stack[top+1] = cp; + top+=2; + bc = procedure_code(tmp); + print_bytecode(bc); + ip = bc->data; + cp = procedure_vars(tmp); + fprintf(stderr, "... calling procedure at %p\ncp: ", ip); + write_sexp(stderr, cp); + fprintf(stderr, "\n"); + /* print_stack(stack, top); */ + break; + case OP_JUMP_UNLESS: + fprintf(stderr, "JUMP UNLESS, stack top is %d\n", stack[top-1]); + if (stack[--top] == SEXP_FALSE) { + fprintf(stderr, "test passed, jumping to + %d => %d\n", ((signed char*)ip)[0], ip + ((signed char*)ip)[0]); + ip += ((signed char*)ip)[0]; + } else { + fprintf(stderr, "test failed, not jumping\n"); + ip++; + } + break; + case OP_JUMP: + fprintf(stderr, "jumping to + %d => %d\n", ((signed char*)ip)[0], ip + ((signed char*)ip)[0]); + ip += ((signed char*)ip)[0]; + break; + case OP_RET: + fprintf(stderr, "returning @ %d: ", top-1); + fflush(stderr); + write_sexp(stderr, stack[top-1]); + fprintf(stderr, "...\n"); + print_stack(stack, top); + /* top-1 */ + /* stack: args ... n ip result */ + cp = stack[top-2]; + fprintf(stderr, "1\n"); + ip = (unsigned char*) stack[top-3]; + fprintf(stderr, "2\n"); + i = unbox_integer(stack[top-4]); + fprintf(stderr, "3 (i=%d)\n", i); + stack[top-i-4] = stack[top-1]; + fprintf(stderr, "4\n"); + top = top-i-3; + fprintf(stderr, "... done returning\n"); + break; + case OP_DONE: + fprintf(stderr, "finally returning @ %d: ", top-1); + fflush(stderr); + write_sexp(stderr, stack[top-1]); + fprintf(stderr, "\n"); + goto end_loop; + default: + fprintf(stderr, "unknown opcode: %d\n", *(ip-1)); + stack[top] = SEXP_ERROR; + goto end_loop; + } + fprintf(stderr, "looping\n"); + goto loop; + + end_loop: + return stack[top-1]; +} + +/************************** eval interface ****************************/ + +sexp eval_in_stack(sexp obj, env e, sexp* stack, unsigned int top) { + bytecode bc = compile(SEXP_NULL, cons(obj, SEXP_NULL), e, SEXP_NULL, SEXP_NULL, 1); + fprintf(stderr, "evaling\n"); + return vm(bc, e, stack, top); +} + +sexp eval(sexp obj, env e) { + sexp* stack = (sexp*) malloc(sizeof(sexp) * INIT_STACK_SIZE); + sexp res = eval_in_stack(obj, e, stack, 0); + free(stack); + return res; +} + +int main (int argc, char **argv) { + sexp obj, res, *stack; + env e; + + sexp_init(); + e = make_standard_env(); + stack = (sexp*) malloc(sizeof(sexp) * INIT_STACK_SIZE); + + /* repl */ + fprintf(stdout, "> "); + fflush(stdout); + while ((obj = read_sexp(stdin)) != SEXP_EOF) { + write_sexp(stdout, obj); + fprintf(stdout, "\n => "); + res = eval_in_stack(obj, e, stack, 0); + write_sexp(stdout, res); + fprintf(stdout, "\n> "); + fflush(stdout); + } + return 0; +} + diff --git a/eval.h b/eval.h new file mode 100644 index 00000000..f8c806e6 --- /dev/null +++ b/eval.h @@ -0,0 +1,119 @@ +/* eval.h -- headers for eval library */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#ifndef SCM_EVAL_H +#define SCM_EVAL_H + +#include "sexp.h" + +/************************* additional types ***************************/ + +#define INIT_BCODE_SIZE 128 +#define INIT_STACK_SIZE 1024 + +typedef struct bytecode { + char tag; + unsigned int len; + unsigned char data[]; +} *bytecode; + +/* env binding: #(id chain offset flags) */ +/* chain is the index into the closure parent list (0 for current lambda) */ +/* macros/constants have a value instead of chain */ +typedef struct env { + char tag; + struct env *parent; + sexp bindings; +} *env; + +typedef struct opcode { + char tag; + char op_class; + char op_name; + char num_args; + char var_args_p; + char arg1_type; + char arg2_type; + char* name; + char op_inverse; + sexp proc; +} *opcode; + +typedef struct core_form { + char tag; + char* name; + char code; +} *core_form; + +enum core_form_names { + CORE_DEFINE, + CORE_SET, + CORE_LAMBDA, + CORE_IF, + CORE_BEGIN, + CORE_QUOTE, + CORE_DEFINE_SYNTAX, + CORE_LET_SYNTAX, + CORE_LETREC_SYNTAX, +}; + +enum opcode_classes { + OPC_GENERIC, + OPC_TYPE_PREDICATE, + OPC_PREDICATE, + OPC_ARITHMETIC, + OPC_ARITHMETIC_INV, + OPC_ARITHMETIC_CMP, + OPC_CONSTRUCTOR, +}; + +enum opcode_names { + OP_NOOP, /* 0 */ + OP_STACK_REF, /* 1 */ + OP_STACK_SET, /* 2 */ + OP_GLOBAL_REF, /* 3 */ + OP_GLOBAL_SET, /* 4 */ + OP_CLOSURE_REF, /* 5 */ + OP_CLOSURE_SET, /* 6 */ + OP_VECTOR_REF, /* 7 */ + OP_VECTOR_SET, /* 8 */ + OP_MAKE_PROCEDURE, + OP_MAKE_VECTOR, + OP_PUSH, + OP_DUP, /* C */ + OP_DROP, + OP_SWAP, + OP_CAR, + OP_CDR, /* 10 */ + OP_SET_CAR, /* 11 */ + OP_SET_CDR, /* 12 */ + OP_CONS, + OP_ADD, /* 14 */ + OP_SUB, + OP_MUL, /* 16 */ + OP_DIV, + OP_MOD, /* 18 */ + OP_NEG, + OP_INV, /* 1A */ + OP_LT, + OP_CALL, /* 1C */ + OP_JUMP_UNLESS, + OP_JUMP, /* 1E */ + OP_RET, + OP_DONE, +}; + +/**************************** prototypes ******************************/ + +bytecode compile(sexp params, sexp obj, env e, sexp fv, sexp sv, int done_p); +void analyze_app (sexp obj, bytecode *bc, unsigned int *i, + env e, sexp params, sexp fv, sexp sv, unsigned int *d); +void analyze_lambda (sexp name, sexp formals, sexp body, + bytecode *bc, unsigned int *i, env e, + sexp params, sexp fv, sexp sv, unsigned int *d); +void analyze_var_ref (sexp name, bytecode *bc, unsigned int *i, env e, + sexp params, sexp fv, sexp sv, unsigned int *d); + +#endif /* ! SCM_EVAL_H */ + diff --git a/sexp.c b/sexp.c index 6a480dcb..1d09e158 100644 --- a/sexp.c +++ b/sexp.c @@ -1,58 +1,24 @@ +/* sexp.c -- sexp library implementation */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ -#include -#include -#include -#include +#include "sexp.h" -/* simple tagging - * ends in 00: pointer - * 01: fixnum - * 011: symbol - * 111: immediate symbol - * 0110: char - * 1110: other immediate object (NULL, TRUE, FALSE) - */ - -#define SEXP_FIXNUM_BITS 2 -#define SEXP_IMMEDIATE_BITS 3 -#define SEXP_EXTENDED_BITS 4 - -#define SEXP_FIXNUM_MASK 3 -#define SEXP_IMMEDIATE_MASK 7 -#define SEXP_EXTENDED_MASK 15 - -#define SEXP_POINTER_TAG 0 -#define SEXP_FIXNUM_TAG 1 -#define SEXP_LSYMBOL_TAG 3 -#define SEXP_ISYMBOL_TAG 7 -#define SEXP_CHAR_TAG 6 - -enum sexp_types { - SEXP_FIXNUM, - SEXP_CHAR, - SEXP_BOOLEAN, - SEXP_PAIR, - SEXP_SYMBOL, - SEXP_STRING, - SEXP_VECTOR, - SEXP_PROCEDURE, - SEXP_ENV, - SEXP_BYTECODE, - SEXP_CORE, - SEXP_OPCODE, +/* optional huffman-compressed immediate symbols */ +#ifdef USE_HUFF_SYMS +struct huff_entry { + unsigned char len; + unsigned short bits; }; - -typedef struct sexp_struct { - char tag; - void *data1; - void *data2; -} *sexp; - #include "sexp-hufftabs.c" +static struct huff_entry huff_table[] = { +#include "sexp-huff.c" +}; +#endif static int initialized_p = 0; -/* static sexp the_dot_symbol; */ +static sexp the_dot_symbol; static sexp the_quote_symbol; static sexp the_quasiquote_symbol; static sexp the_unquote_symbol; @@ -63,116 +29,6 @@ static sexp the_define_symbol; static sexp the_set_x_symbol; static sexp the_if_symbol; -#define MAKE_IMMEDIATE(n) ((sexp) ((n<<4) + 14)) -#define SEXP_NULL MAKE_IMMEDIATE(0) -#define SEXP_FALSE MAKE_IMMEDIATE(1) -#define SEXP_TRUE MAKE_IMMEDIATE(2) -#define SEXP_EOF MAKE_IMMEDIATE(3) -#define SEXP_UNDEF MAKE_IMMEDIATE(4) -#define SEXP_ERROR MAKE_IMMEDIATE(5) -#define SEXP_CLOSE MAKE_IMMEDIATE(6) /* internal use */ -#define SEXP_RAWDOT MAKE_IMMEDIATE(7) /* internal use */ - -#define SEXP_NULLP(x) ((x) == SEXP_NULL) -#define SEXP_POINTERP(x) (((unsigned long)(x) & SEXP_FIXNUM_MASK) == SEXP_POINTER_TAG) -#define SEXP_INTEGERP(x) (((unsigned long)(x) & SEXP_FIXNUM_MASK) == SEXP_FIXNUM_TAG) -#define SEXP_ISYMBOLP(x) (((unsigned long)(x) & SEXP_IMMEDIATE_MASK) == SEXP_ISYMBOL_TAG) -#define SEXP_CHARP(x) (((unsigned long)(x) & SEXP_EXTENDED_MASK) == SEXP_CHAR_TAG) -#define SEXP_BOOLEANP(x) (((x) == SEXP_TRUE) || ((x) == SEXP_FALSE)) - -#define SEXP_PAIRP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_PAIR) -#define SEXP_STRINGP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_STRING) -#define SEXP_LSYMBOLP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_SYMBOL) -#define SEXP_VECTORP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_VECTOR) -#define SEXP_PROCEDUREP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_PROCEDURE) -#define SEXP_ENVP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_ENV) -#define SEXP_BYTECODEP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag ==SEXP_BYTECODE) -#define SEXP_COREP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_CORE) -#define SEXP_OPCODEP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_OPCODE) - -#define SEXP_SYMBOLP(x) (SEXP_ISYMBOLP(x) || SEXP_LSYMBOLP(x)) - -/* #define SEXP_DOTP(x) (SEXP_SYMBOLP(x) && (strncmp(string_data(x), ".", 2) == 0)) */ -/* #define SEXP_DOTP(x) (x==the_dot_symbol) */ -#define SEXP_DOTP(x) (((unsigned long)(x))==((0x5D00<>SEXP_FIXNUM_BITS) -#define make_character(n) ((sexp) (((long) n<>SEXP_EXTENDED_BITS) - -#define vector_length(x) ((unsigned long) x->data1) -#define vector_data(x) ((sexp*) x->data2) - -#define vector_ref(x, i) (vector_data(x)[unbox_integer(i)]) -#define vector_set(x, i, v) (vector_data(x)[unbox_integer(i)] = (v)) - -#define procedure_code(x) ((bytecode) ((sexp)x)->data1) -#define procedure_vars(x) ((sexp) ((sexp)x)->data2) - -#define string_length(x) ((unsigned long) x->data1) -#define string_data(x) ((char*) x->data2) - -#define symbol_pointer(x) ((sexp) (((unsigned long)x)-SEXP_LSYMBOL_TAG)) -#define symbol_length(x) ((unsigned long) (symbol_pointer(x)->data1)) -#define symbol_data(x) ((char*) (symbol_pointer(x)->data2)) - -#define sexp_add(a, b) ((sexp)(((unsigned long)a)+((unsigned long)b)-SEXP_FIXNUM_TAG)) -#define sexp_sub(a, b) ((sexp)(((unsigned long)a)-((unsigned long)b)+SEXP_FIXNUM_TAG)) -#define sexp_mul(a, b) ((sexp)((((((unsigned long)a)-SEXP_FIXNUM_TAG)*(((unsigned long)b)>>SEXP_FIXNUM_BITS))+SEXP_FIXNUM_TAG))) -#define sexp_div(a, b) ((sexp)(((((unsigned long)a)>>SEXP_FIXNUM_BITS)/(((unsigned long)b)>>SEXP_FIXNUM_BITS))<>SEXP_FIXNUM_BITS)%(((unsigned long)b)>>SEXP_FIXNUM_BITS))<tag = SEXP_PAIR; - pair->data1 = (void*) head; - pair->data2 = (void*) tail; - return pair; -} - -#define list2(a, b) cons(a, cons(b, SEXP_NULL)) -#define list3(a, b, c) cons(a, cons(b, cons(c, SEXP_NULL))) -#define list4(a, b, c, d) cons(a, cons(b, cons(c, cons(d, SEXP_NULL)))) - -#define SEXP_CAR(x) (((sexp)x)->data1) -#define SEXP_CDR(x) (((sexp)x)->data2) - -#define SEXP_CAAR(x) (SEXP_CAR(SEXP_CAR(x))) -#define SEXP_CADR(x) (SEXP_CAR(SEXP_CDR(x))) -#define SEXP_CDAR(x) (SEXP_CDR(SEXP_CAR(x))) -#define SEXP_CDDR(x) (SEXP_CDR(SEXP_CDR(x))) - -#define SEXP_CADDR(x) (SEXP_CAR(SEXP_CDDR(x))) -#define SEXP_CDDDR(x) (SEXP_CDR(SEXP_CDDR(x))) -#define SEXP_CADDDR(x) (SEXP_CADR(SEXP_CDDR(x))) -#define SEXP_CDDDDR(x) (SEXP_CDDR(SEXP_CDDR(x))) - -sexp read_sexp (FILE *in); - -/* separators: space, tab, newline, ; () [] , ' " */ -/* 9 10 11 12 13 32 34 39 40 41 44 59 91 93 */ -/* 0 1 2 3 4 23 25 30 31 32 35 50 82 84 */ -/* 0000000 */ -/* 0000001 */ -/* 0000010 */ -/* 0000011 */ -/* 0000100 */ -/* 0010111 */ -/* 0011001 */ -/* 0011110 */ -/* 0011111 */ -/* 0100000 */ -/* 0100011 */ -/* 0110010 */ -/* 1010010 */ -/* 1010100 */ - static char 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_ */ @@ -185,11 +41,56 @@ static char separators[] = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* x7_ */ }; -static int is_separator (int c) { +static int is_separator(int c) { /* return (!((c-9)&(~3))) | (~(c^4)); */ return 0tag) { + case SEXP_PAIR: + free_sexp(car(obj)); + free_sexp(cdr(obj)); + break; + case SEXP_VECTOR: + len = vector_length(obj); + elts = vector_data(obj); + for (i=0; itag = SEXP_PAIR; + pair->data1 = (void*) head; + pair->data2 = (void*) tail; + return pair; +} + sexp car(sexp obj) { return (SEXP_PAIRP(obj)) ? SEXP_CAR(obj) : SEXP_ERROR; } @@ -199,19 +100,17 @@ sexp cdr(sexp obj) { } sexp set_car(sexp obj, sexp val) { - if (SEXP_PAIRP(obj)) { + if (SEXP_PAIRP(obj)) return SEXP_CAR(obj) = val; - } else { + else return SEXP_ERROR; - } } sexp set_cdr(sexp obj, sexp val) { - if (SEXP_PAIRP(obj)) { + if (SEXP_PAIRP(obj)) return SEXP_CDR(obj) = val; - } else { + else return SEXP_ERROR; - } } int listp (sexp obj) { @@ -231,6 +130,24 @@ int list_index (sexp ls, sexp elt) { return -1; } +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 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 lset_diff(sexp a, sexp b) { sexp res = SEXP_NULL; for ( ; SEXP_PAIRP(a); a=SEXP_CDR(a)) @@ -247,23 +164,18 @@ sexp reverse(sexp ls) { } sexp nreverse(sexp ls) { - sexp a; - sexp b; - sexp tmp; - + sexp a, b, tmp; if (ls == SEXP_NULL) { return ls; } else if (! SEXP_PAIRP(ls)) { return SEXP_ERROR; } else { - b = ls; + b=ls; a=cdr(ls); set_cdr(b, SEXP_NULL); - for ( ; SEXP_PAIRP(a); ) { - tmp = cdr(a); + for ( ; SEXP_PAIRP(a); b=a, a=tmp) { + tmp=cdr(a); set_cdr(a, b); - b = a; - a = tmp; } return b; } @@ -279,35 +191,13 @@ sexp list(int count, ...) { sexp res = SEXP_NULL; int i; va_list ap; - va_start(ap, count); - for (i=0; i d*4) { - fprintf(stderr, "resizing symbol table\n"); - newtable = malloc(symbol_table_primes[symbol_table_prime_index++] - * sizeof(sexp)); - free(symbol_table); + newtable = SEXP_ALLOC(symbol_table_primes[symbol_table_prime_index++] + * sizeof(sexp)); + SEXP_FREE(symbol_table); symbol_table = newtable; } @@ -435,9 +308,8 @@ sexp list_to_vector(sexp ls) { sexp x; sexp *elts = vector_data(vec); int i; - for (i=0, x=ls; SEXP_PAIRP(x); i++, x=cdr(x)) { + for (i=0, x=ls; SEXP_PAIRP(x); i++, x=cdr(x)) elts[i] = car(x); - } return vec; } @@ -449,23 +321,21 @@ sexp vector(int count, ...) { int i; va_start(ap, count); - for (i=0; i"); - } else if (SEXP_POINTERP(obj)) { - switch (obj->tag) { case SEXP_PAIR: fprintf(out, "("); @@ -482,7 +352,7 @@ void write_sexp (FILE *out, sexp obj) { break; case SEXP_VECTOR: len = vector_length(obj); - sexp *elts = vector_data(obj); + elts = vector_data(obj); if (len == 0) { fprintf(out, "#()"); } else { @@ -509,41 +379,32 @@ void write_sexp (FILE *out, sexp obj) { /* FALLTHROUGH */ case SEXP_SYMBOL: fprintf(out, "%s", string_data(obj)); - if (obj->tag == SEXP_STRING) { + if (obj->tag == SEXP_STRING) fprintf(out, "\""); - } break; } - } else if (SEXP_INTEGERP(obj)) { - fprintf(out, "%d", unbox_integer(obj)); - } else if (SEXP_CHARP(obj)) { - if (33 <= unbox_character(obj) < 127) { fprintf(out, "#\\%c", unbox_character(obj)); } else { fprintf(out, "#\\x%02d", unbox_character(obj)); } - } else if (SEXP_SYMBOLP(obj)) { +#ifdef USE_HUFF_SYMS if (((unsigned long)obj&7)==7) { - c = ((unsigned long)obj)>>3; - while (c) { #include "sexp-unhuff.c" putc(res, out); } + } else +#endif - } else { fprintf(out, "%s", symbol_data(obj)); - } - } else { - switch ((unsigned long) obj) { case (int) SEXP_NULL: fprintf(out, "()"); @@ -566,34 +427,6 @@ void write_sexp (FILE *out, sexp obj) { } } -void* free_sexp (sexp obj) { - int len, i; - sexp *elts; - - if (SEXP_POINTERP(obj)) { - switch (obj->tag) { - case SEXP_PAIR: - free_sexp(car(obj)); - free_sexp(cdr(obj)); - break; - case SEXP_VECTOR: - len = vector_length(obj); - elts = vector_data(obj); - for (i=0; i -#else -#define errx(code, msg, ...) (fprintf(stderr,msg"\n",__VA_ARGS__), exit(code)) -#endif - -#define INIT_BCODE_SIZE 128 -#define INIT_STACK_SIZE 1024 - -typedef struct bytecode { - char tag; - unsigned int len; - unsigned char data[]; -} *bytecode; - -/* env binding: #(id chain offset flags) */ -/* chain is the index into the closure parent list (0 for current lambda) */ -/* macros/constants have a value instead of chain */ -typedef struct env { - char tag; - struct env *parent; - sexp bindings; -} *env; - -enum core_form_names { - CORE_DEFINE, - CORE_SET, - CORE_LAMBDA, - CORE_IF, - CORE_BEGIN, - CORE_QUOTE, - CORE_DEFINE_SYNTAX, - CORE_LET_SYNTAX, - CORE_LETREC_SYNTAX, -}; - -typedef struct core_form { - char tag; - char* name; - char code; -} *core_form; - -static struct core_form core_forms[] = { - {SEXP_CORE, "define", CORE_DEFINE}, - {SEXP_CORE, "set!", CORE_SET}, - {SEXP_CORE, "lambda", CORE_LAMBDA}, - {SEXP_CORE, "if", CORE_IF}, - {SEXP_CORE, "begin", CORE_BEGIN}, - {SEXP_CORE, "quote", CORE_QUOTE}, - {SEXP_CORE, "define-syntax", CORE_DEFINE_SYNTAX}, - {SEXP_CORE, "let-syntax", CORE_LET_SYNTAX}, - {SEXP_CORE, "letrec-syntax", CORE_LETREC_SYNTAX}, -}; - -enum opcode_classes { - OPC_GENERIC, - OPC_TYPE_PREDICATE, - OPC_PREDICATE, - OPC_ARITHMETIC, - OPC_ARITHMETIC_INV, - OPC_ARITHMETIC_CMP, - OPC_CONSTRUCTOR, -}; - -/* #define OP_UNSAFE(op) ((op)+128) */ - -enum opcode_names { - OP_NOOP, /* 0 */ - OP_STACK_REF, /* 1 */ - OP_STACK_SET, /* 2 */ - OP_GLOBAL_REF, /* 3 */ - OP_GLOBAL_SET, /* 4 */ - OP_CLOSURE_REF, /* 5 */ - OP_CLOSURE_SET, /* 6 */ - OP_VECTOR_REF, /* 7 */ - OP_VECTOR_SET, /* 8 */ - OP_MAKE_PROCEDURE, - OP_MAKE_VECTOR, - OP_PUSH, - OP_DUP, /* C */ - OP_DROP, - OP_SWAP, - OP_CAR, - OP_CDR, /* 10 */ - OP_SET_CAR, /* 11 */ - OP_SET_CDR, /* 12 */ - OP_CONS, - OP_ADD, /* 14 */ - OP_SUB, - OP_MUL, /* 16 */ - OP_DIV, - OP_MOD, /* 18 */ - OP_NEG, - OP_INV, /* 1A */ - OP_LT, - OP_CALL, /* 1C */ - OP_JUMP_UNLESS, - OP_JUMP, /* 1E */ - OP_RET, - OP_DONE, -}; - -static const char* reverse_opcode_names[] = - {"NOOP", "STACK_REF", "STACK_SET", "GLOBAL_REF", "GLOBAL_SET", "CLOSURE_REF", - "CLOSURE_SET", "VECTOR_REF", "VECTOR_SET", "MAKE_PROCEDURE", "MAKE_VECTOR", - "PUSH", "DUP", "DROP", "SWAP", "CAR", "CDR", "SET_CAR", "SET_CDR", "CONS", - "ADD", "SUB", "MUL", "DIV", "MOD", "NEG", "INV", "LT", "CALL", - "JUMP_UNLESS", "JUMP", "RET", "DONE" - }; - -typedef struct opcode { - char tag; - char op_class; - char op_name; - char num_args; - char var_args_p; - char arg1_type; - char arg2_type; - char* name; - char op_inverse; - sexp proc; -} *opcode; - -static struct opcode opcodes[] = { -{SEXP_OPCODE, OPC_TYPE_PREDICATE, OP_CAR, 1, 0, SEXP_PAIR, 0, "car", 0, NULL}, -{SEXP_OPCODE, OPC_TYPE_PREDICATE, OP_CDR, 1, 0, SEXP_PAIR, 0, "cdr", 0, NULL}, -{SEXP_OPCODE, OPC_ARITHMETIC, OP_ADD, 0, 1, SEXP_FIXNUM, 0, "+", 0, NULL}, -{SEXP_OPCODE, OPC_ARITHMETIC_INV, OP_SUB, 0, 1, SEXP_FIXNUM, 0, "-", OP_NEG, NULL}, -{SEXP_OPCODE, OPC_ARITHMETIC, OP_MUL, 0, 1, SEXP_FIXNUM, 0, "*", 0, NULL}, -{SEXP_OPCODE, OPC_ARITHMETIC_INV, OP_DIV, 0, 1, SEXP_FIXNUM, 0, "/", OP_INV, 0}, -{SEXP_OPCODE, OPC_ARITHMETIC, OP_MOD, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, "%", 0, NULL}, -{SEXP_OPCODE, OPC_ARITHMETIC_CMP, OP_LT, 0, 1, SEXP_FIXNUM, 0, "<", 0, NULL}, -{SEXP_OPCODE, OPC_CONSTRUCTOR, OP_CONS, 2, 0, 0, 0, "cons", 0, NULL}, -{SEXP_OPCODE, OPC_CONSTRUCTOR, OP_MAKE_VECTOR, 2, 0, SEXP_FIXNUM, 0, "make-vector", 0, NULL}, -{SEXP_OPCODE, OPC_CONSTRUCTOR, OP_MAKE_PROCEDURE, 2, 0, 0, 0, "make-procedure", 0, NULL}, -}; - -void disasm (bytecode bc) { - unsigned char *ip=bc->data, opcode; - loop: - opcode = *ip++; - if (opcode*sizeof(char*) < sizeof(reverse_opcode_names)) { - fprintf(stderr, " %s ", reverse_opcode_names[opcode]); - } else { - fprintf(stderr, " %d ", opcode); - } - switch (opcode) { - case OP_STACK_REF: - case OP_STACK_SET: - case OP_CLOSURE_REF: - case OP_CLOSURE_SET: - fprintf(stderr, "%d", (long) ((sexp*)ip)[0]); - ip += sizeof(sexp); - break; - case OP_GLOBAL_REF: - case OP_GLOBAL_SET: - case OP_CALL: - case OP_PUSH: - write_sexp(stderr, ((sexp*)ip)[0]); - ip += sizeof(sexp); - break; - case OP_JUMP: - case OP_JUMP_UNLESS: - fprintf(stderr, "%d", ip[0]); - ip++; - break; - } - fprintf(stderr, "\n"); - if ((! (opcode == OP_RET) || (opcode == OP_DONE)) - && (ip - bc->data < bc->len)) - goto loop; -} - -sexp env_cell(env e, sexp key) { - sexp ls, res=NULL; - - do { - for (ls=e->bindings; SEXP_PAIRP(ls); ls=SEXP_CDR(ls)) { - if (SEXP_CAAR(ls) == key) { - res = SEXP_CAR(ls); - break; - } - } - e = e->parent; - } while (e && ! res); - - return res; -} - -sexp make_procedure(sexp bc, sexp vars) { - sexp proc = SEXP_NEW(); - if (! proc) return SEXP_ERROR; - proc->tag = SEXP_PROCEDURE; - proc->data1 = (void*) bc; - proc->data2 = (void*) vars; - return proc; -} - -int env_global_p (env e, sexp id) { - while (e->parent) { - if (assq(id, e->bindings) != SEXP_FALSE) - return 0; - else - e = e->parent; - } - return 1; -} - -void env_define(env e, sexp key, sexp value) { - sexp cell = env_cell(e, key); - if (cell) { - SEXP_CDR(cell) = value; - } else { - e->bindings = cons(cons(key, value), e->bindings); } } -env extend_env_closure (env e, sexp fv) { - int i; - env e2 = (env) malloc(sizeof(struct env)); - e2->tag = SEXP_ENV; - e2->parent = e; - e2->bindings = SEXP_NULL; - for (i=0; SEXP_PAIRP(fv); fv = SEXP_CDR(fv), i++) { - e2->bindings = cons(cons(SEXP_CAR(fv), make_integer(i)), e2->bindings); - } - return e2; -} - -env make_standard_env() { - int i; - env e = (env) malloc(sizeof(struct env)); - e->tag = SEXP_ENV; - e->parent = NULL; - e->bindings = SEXP_NULL; - for (i=0; i<(sizeof(core_forms)/sizeof(struct core_form)); i++) { - env_define(e, intern(core_forms[i].name), (sexp)(&core_forms[i])); - } - for (i=0; i<(sizeof(opcodes)/sizeof(struct opcode)); i++) { - env_define(e, intern(opcodes[i].name), (sexp)(&opcodes[i])); - } - return e; -} - -/* ******************************************************************** */ - -/* char *buffncpy(char *buf, unsigned int n, unsigned int len) { */ -/* char *res; */ -/* if (n==len) { */ -/* res = buf; */ -/* } else { */ -/* res = (char*) malloc(n); */ -/* strncpy(res, buf, n); */ -/* free(buf); */ -/* } */ -/* return res; */ -/* } */ - -/* char *buffngrow(char *buf, unsigned int newlen) { */ -/* char *tmp = (char*) malloc(newlen); */ -/* strncpy(tmp, buf, newlen/2); */ -/* free(buf); */ -/* return tmp; */ -/* } */ - -void print_bytecode (bytecode bc) { - int i; - fprintf(stderr, "bytecode @ %p, data @ %p, length = %d\n", bc, bc->data, bc->len); - for (i=0; i+16 < bc->len; i+=8) { - fprintf(stderr, "%02x: %02x %02x %02x %02x %02x %02x %02x %02x ", i, - bc->data[i], bc->data[i+1], bc->data[i+2], bc->data[i+3], - bc->data[i+4], bc->data[i+5], bc->data[i+6], bc->data[i+7]); - i += 8; - fprintf(stderr, "%02x %02x %02x %02x %02x %02x %02x %02x\n", - bc->data[i], bc->data[i+1], bc->data[i+2], bc->data[i+3], - bc->data[i+4], bc->data[i+5], bc->data[i+6], bc->data[i+7]); - } - if (i != bc->len) { - fprintf(stderr, "%02x:", i); - for ( ; i < bc->len; i++) { - if ((i % 8) == 0 && (i % 16) != 0) - fprintf(stderr, " "); - fprintf(stderr, " %02x", bc->data[i]); - } - fprintf(stderr, "\n"); - } -} - -void print_stack (sexp *stack, int top) { - int i; - for (i=0; ilen != i) { - fprintf(stderr, "shrinking to %d\n", i); - tmp = (bytecode) malloc(sizeof(struct bytecode) + i); - tmp->tag = SEXP_BYTECODE; - tmp->len = i; - memcpy(tmp->data, (*bc)->data, i); - SEXP_FREE(*bc); - *bc = tmp; - } -} - -void emit(bytecode *bc, unsigned int *i, char c) { - bytecode tmp; - if ((*bc)->len < (*i)+1) { - fprintf(stderr, "expanding (%d < %d)\n", (*bc)->len, (*i)+1); - tmp = (bytecode) malloc(sizeof(unsigned int) + (*bc)->len*2); - tmp->len = (*bc)->len*2; - memcpy(tmp->data, (*bc)->data, (*bc)->len); - SEXP_FREE(*bc); - *bc = tmp; - } - (*bc)->data[(*i)++] = c; -} - -void emit_word(bytecode *bc, unsigned int *i, unsigned long val) { - bytecode tmp; - if ((*bc)->len < (*i)+4) { - tmp = (bytecode) malloc(sizeof(unsigned int) + (*bc)->len*2); - tmp->len = (*bc)->len*2; - memcpy(tmp->data, (*bc)->data, (*bc)->len); - SEXP_FREE(*bc); - *bc = tmp; - } - *((unsigned long*)(&((*bc)->data[*i]))) = val; - *i += sizeof(unsigned long); -} - -bytecode compile(sexp params, sexp obj, env e, sexp fv, sexp sv, int done_p); -void analyze_app (sexp obj, bytecode *bc, unsigned int *i, - env e, sexp params, sexp fv, sexp sv, unsigned int *d); -void analyze_lambda (sexp name, sexp formals, sexp body, - bytecode *bc, unsigned int *i, env e, - sexp params, sexp fv, sexp sv, unsigned int *d); -void analyze_var_ref (sexp name, bytecode *bc, unsigned int *i, env e, - sexp params, sexp fv, sexp sv, unsigned int *d); - -void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, - sexp params, sexp fv, sexp sv, unsigned int *d) { - int tmp1, tmp2; - env e2 = e; - sexp o1, o2, cell; - - if (SEXP_PAIRP(obj)) { - /* fprintf(stderr, ":: pair\n"); */ - if (SEXP_SYMBOLP(SEXP_CAR(obj))) { - fprintf(stderr, ":: symbol application\n"); - o1 = env_cell(e, SEXP_CAR(obj)); - /* fprintf(stderr, ":: => %p\n", o1); */ - if (! o1) - errx(1, "unknown operator: %s", SEXP_CAR(obj)); - o1 = SEXP_CDR(o1); - /* fprintf(stderr, ":: => %p\n", o1); */ - if (SEXP_COREP(o1)) { - /* core form */ - fprintf(stderr, ":: core form\n"); - switch (((core_form)o1)->code) { - case CORE_LAMBDA: - fprintf(stderr, ":: lambda\n"); - analyze_lambda(SEXP_FALSE, SEXP_CADR(obj), SEXP_CDDR(obj), - bc, i, e, params, fv, sv, d); - break; - case CORE_DEFINE: - fprintf(stderr, "compiling global set: %p\n", SEXP_CADR(obj)); - if ((((core_form)o1)->code == CORE_DEFINE) - && SEXP_PAIRP(SEXP_CADR(obj))) { - analyze_lambda(SEXP_CAR(SEXP_CADR(obj)), - SEXP_CDR(SEXP_CADR(obj)), - SEXP_CDDR(obj), - bc, i, e, params, fv, sv, d); - } else { - analyze(SEXP_CADDR(obj), bc, i, e, params, fv, sv, d); - } - emit(bc, i, OP_GLOBAL_SET); - emit_word(bc, i, (unsigned long) (SEXP_PAIRP(SEXP_CADR(obj)) - ? SEXP_CAR(SEXP_CADR(obj)) - : SEXP_CADR(obj))); - emit(bc, i, OP_PUSH); - (*d)++; - emit_word(bc, i, (unsigned long) SEXP_UNDEF); - break; - case CORE_SET: - fprintf(stderr, "set!: "); write_sexp(stderr, SEXP_CADR(obj)); - fprintf(stderr, " sv: "); write_sexp(stderr, sv); - fprintf(stderr, "\n"); - analyze(SEXP_CADDR(obj), bc, i, e, params, fv, sv, d); - analyze_var_ref(SEXP_CADR(obj), bc, i, e, params, fv, SEXP_NULL, d); - emit(bc, i, OP_SET_CAR); - break; - case CORE_BEGIN: - for (o2 = SEXP_CDR(obj); SEXP_PAIRP(o2); o2 = SEXP_CDR(o2)) { - analyze(SEXP_CAR(o2), bc, i, e, params, fv, sv, d); - if (SEXP_PAIRP(SEXP_CDR(o2))) emit(bc, i, OP_DROP); - } - break; - case CORE_IF: - fprintf(stderr, "test clause: %d\n", *i); - analyze(SEXP_CADR(obj), bc, i, e, params, fv, sv, d); - emit(bc, i, OP_JUMP_UNLESS); /* jumps if test fails */ - tmp1 = *i; - emit(bc, i, 0); - fprintf(stderr, "pass clause: %d\n", *i); - analyze(SEXP_CADDR(obj), bc, i, e, params, fv, sv, d); - emit(bc, i, OP_JUMP); - tmp2 = *i; - emit(bc, i, 0); - ((signed char*) (*bc)->data)[tmp1] = (*i)-tmp1-1; /* patch */ - fprintf(stderr, "fail clause: %d\n", *i); - if (SEXP_PAIRP(SEXP_CDDDR(obj))) { - analyze(SEXP_CADDDR(obj), bc, i, e, params, fv, sv, d); - } else { - emit(bc, i, OP_PUSH); - (*d)++; - emit_word(bc, i, (unsigned long) SEXP_UNDEF); - } - ((signed char*) (*bc)->data)[tmp2] = (*i)-tmp2-1; /* patch */ - break; - case CORE_QUOTE: - emit(bc, i, OP_PUSH); - (*d)++; - emit_word(bc, i, (unsigned long)SEXP_CADR(obj)); - break; - default: - errx(1, "unknown core form: %s", ((core_form)o1)->code); - } - } else if (SEXP_OPCODEP(o1)) { - fprintf(stderr, ":: opcode\n"); - /* direct opcode */ - /* verify arity */ - switch (((opcode)o1)->op_class) { - case OPC_TYPE_PREDICATE: - case OPC_PREDICATE: - case OPC_ARITHMETIC: - case OPC_ARITHMETIC_INV: - case OPC_ARITHMETIC_CMP: - if (SEXP_NULLP(SEXP_CDR(obj))) { - errx(1, "unknown opcode class: %d", ((opcode)o1)->op_class); - } else if (SEXP_NULLP(SEXP_CDDR(obj))) { - if (((opcode)o1)->op_class == OPC_ARITHMETIC_INV) { - analyze(SEXP_CADR(obj), bc, i, e, params, fv, sv, d); - emit(bc, i, ((opcode)o1)->op_inverse); - } else { - analyze(SEXP_CADR(obj), bc, i, e, params, fv, sv, d); - } - } else { - /* fprintf(stderr, ":: class: %d\n", ((opcode)o1)->op_class); */ - for (o2 = reverse(SEXP_CDR(obj)); SEXP_PAIRP(o2); o2 = SEXP_CDR(o2)) { - /* fprintf(stderr, ":: arg: %d\n", SEXP_CAR(o2)); */ - analyze(SEXP_CAR(o2), bc, i, e, params, fv, sv, d); - } - fprintf(stderr, ":: name: %d\n", ((opcode)o1)->op_name); - emit(bc, i, ((opcode)o1)->op_name); - (*d) -= length(SEXP_CDDR(obj)); - } - break; - default: - errx(1, "unknown opcode class: %d", ((opcode)o1)->op_class); - } - } else { - /* function call */ - analyze_app(obj, bc, i, e, params, fv, sv, d); - } - } else if (SEXP_PAIRP(SEXP_CAR(obj))) { - o2 = env_cell(e, SEXP_CAAR(obj)); -/* if (o2 */ -/* && SEXP_COREP(SEXP_CDR(o2)) */ -/* && (((core_form)SEXP_CDR(o2))->code == CORE_LAMBDA)) { */ -/* /\* let *\/ */ -/* } else { */ - /* computed application */ - analyze_app(obj, bc, i, e, params, fv, sv, d); -/* } */ - } else { - errx(1, "invalid operator: %s", SEXP_CAR(obj)); - } - } else if (SEXP_SYMBOLP(obj)) { - analyze_var_ref(obj, bc, i, e, params, fv, sv, d); - } else { - fprintf(stderr, "push: %d\n", (unsigned long)obj); - emit(bc, i, OP_PUSH); - emit_word(bc, i, (unsigned long)obj); - (*d)++; - } -} - -void analyze_var_ref (sexp obj, bytecode *bc, unsigned int *i, env e, - sexp params, sexp fv, sexp sv, unsigned int *d) { - int tmp; - /* variable reference */ - /* cell = env_cell(e, obj); */ - fprintf(stderr, "symbol lookup, param length: %d sv: ", length(params)); - write_sexp(stderr, sv); - fprintf(stderr, "\n"); - if ((tmp = list_index(params, obj)) >= 0) { - fprintf(stderr, "compiling local ref: %p => %d (d = %d)\n", obj, tmp, *d); - emit(bc, i, OP_STACK_REF); - emit_word(bc, i, tmp + *d + 4); - (*d)++; - } else if ((tmp = list_index(fv, obj)) >= 0) { - fprintf(stderr, "compiling closure ref: %p => %d\n", obj, tmp); - emit(bc, i, OP_CLOSURE_REF); - emit_word(bc, i, tmp); - (*d)++; - } else { - fprintf(stderr, "compiling global ref: %p\n", obj); - emit(bc, i, OP_GLOBAL_REF); - emit_word(bc, i, (unsigned long) obj); - (*d)++; - } - if (list_index(sv, obj) >= 0) { - fprintf(stderr, "mutable variables, fetching CAR\n"); - emit(bc, i, OP_CAR); - } -} - -void analyze_app (sexp obj, bytecode *bc, unsigned int *i, - env e, sexp params, sexp fv, sexp sv, unsigned int *d) { - sexp o1; - unsigned long len = length(SEXP_CDR(obj)); - - /* push the arguments onto the stack */ - for (o1 = reverse(SEXP_CDR(obj)); SEXP_PAIRP(o1); o1 = SEXP_CDR(o1)) { - analyze(SEXP_CAR(o1), bc, i, e, params, fv, sv, d); - } - - /* push the operator onto the stack */ - analyze(SEXP_CAR(obj), bc, i, e, params, fv, sv, d); - - /* make the call */ - emit(bc, i, OP_CALL); - emit_word(bc, i, (unsigned long) make_integer(len)); -} - -sexp free_vars (env e, sexp formals, sexp obj, sexp fv) { - sexp o1; - if (SEXP_SYMBOLP(obj)) { - if (env_global_p(e, obj) - || (list_index(formals, obj) >= 0) - || (list_index(fv, obj) >= 0)) - return fv; - else - return cons(obj, fv); - } else if (SEXP_PAIRP(obj)) { - if (SEXP_SYMBOLP(SEXP_CAR(obj))) { - if ((o1 = env_cell(e, SEXP_CAR(obj))) - && SEXP_COREP(o1) - && (((core_form)SEXP_CDR(o1))->code == CORE_LAMBDA)) { - return free_vars(e, SEXP_CADR(obj), SEXP_CADDR(obj), fv); - } - } - while (SEXP_PAIRP(obj)) { - fv = free_vars(e, formals, SEXP_CAR(obj), fv); - obj = SEXP_CDR(obj); - } - return fv; - } else { - return fv; - } -} - -sexp set_vars (env e, sexp formals, sexp obj, sexp sv) { - sexp tmp; - if (SEXP_NULLP(formals)) - return sv; - if (SEXP_PAIRP(obj)) { - if (SEXP_SYMBOLP(SEXP_CAR(obj))) { - if ((tmp = env_cell(e, SEXP_CAR(obj))) && SEXP_COREP(SEXP_CDR(tmp))) { - if (((core_form)SEXP_CDR(tmp))->code == CORE_LAMBDA) { - formals = lset_diff(formals, SEXP_CADR(obj)); - return set_vars(e, formals, SEXP_CADDR(obj), sv); - } else if (((core_form)SEXP_CDR(tmp))->code == CORE_SET) { - if ((list_index(formals, SEXP_CADR(obj)) >= 0) - && ! (list_index(sv, SEXP_CADR(obj)) >= 0)) { - fprintf(stderr, "found set! "); write_sexp(stderr, SEXP_CADR(obj)); - fprintf(stderr, "\n"); - sv = cons(SEXP_CADR(obj), sv); - return set_vars(e, formals, SEXP_CADDR(obj), sv); - } - } - } - } - while (SEXP_PAIRP(obj)) { - sv = set_vars(e, formals, SEXP_CAR(obj), sv); - obj = SEXP_CDR(obj); - } - } - return sv; -} - -void analyze_lambda (sexp name, sexp formals, sexp body, - bytecode *bc, unsigned int *i, env e, - sexp params, sexp fv, sexp sv, unsigned int *d) { - sexp obj; - sexp fv2 = free_vars(e, formals, body, SEXP_NULL), ls; - env e2 = extend_env_closure(e, formals); - int k; - fprintf(stderr, "%d free-vars\n", length(fv2)); - write_sexp(stderr, fv2); - fprintf(stderr, "\n"); - obj = (sexp) compile(formals, body, e2, fv2, sv, 0); - emit(bc, i, OP_PUSH); - emit_word(bc, i, (unsigned long) SEXP_UNDEF); - emit(bc, i, OP_PUSH); - emit_word(bc, i, (unsigned long) make_integer(length(fv2))); - emit(bc, i, OP_MAKE_VECTOR); - (*d)++; - for (ls=fv2, k=0; SEXP_PAIRP(ls); ls=SEXP_CDR(ls), k++) { - analyze_var_ref(SEXP_CAR(ls), bc, i, e, params, fv, SEXP_NULL, d); - emit(bc, i, OP_PUSH); - emit_word(bc, i, (unsigned long) make_integer(k)); - emit(bc, i, OP_STACK_REF); - emit_word(bc, i, 3); - emit(bc, i, OP_VECTOR_SET); - emit(bc, i, OP_DROP); - (*d)--; - } - emit(bc, i, OP_PUSH); - emit_word(bc, i, (unsigned long) obj); - emit(bc, i, OP_MAKE_PROCEDURE); -} - -sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { - unsigned char *ip=bc->data; - sexp cp, tmp; - int i; - - loop: - /* fprintf(stderr, "opcode: %d, ip: %d\n", *ip, ip); */ - /* print_bytecode(bc); */ - switch (*ip++) { - case OP_NOOP: - fprintf(stderr, "noop\n"); - break; - case OP_GLOBAL_REF: - fprintf(stderr, "global ref: ip: %p => %p: ", ip, ((sexp*)ip)[0]); - fflush(stderr); - write_sexp(stderr, ((sexp*)ip)[0]); - fprintf(stderr, "\n"); - tmp = env_cell(e, ((sexp*)ip)[0]); - stack[top++]=SEXP_CDR(tmp); - ip += sizeof(sexp); - break; - case OP_GLOBAL_SET: - fprintf(stderr, "global set: %p: ", ((sexp*)ip)[0]); - fflush(stderr); - write_sexp(stderr, ((sexp*)ip)[0]); - fprintf(stderr, "\n"); - env_define(e, ((sexp*)ip)[0], stack[--top]); - ip += sizeof(sexp); - break; - case OP_STACK_REF: - fprintf(stderr, "stack ref: ip=%p, %d - %d => ", - ip, top, (unsigned long) ((sexp*)ip)[0]); - fflush(stderr); - write_sexp(stderr, stack[top - (unsigned int) ((sexp*)ip)[0]]); - fprintf(stderr, "\n"); - stack[top] = stack[top - (unsigned int) ((sexp*)ip)[0]]; - ip += sizeof(sexp); - top++; - break; - case OP_STACK_SET: - stack[top - (unsigned int) ((sexp*)ip)[0]] = stack[top-1]; - stack[top-1] = SEXP_UNDEF; - ip += sizeof(sexp); - break; - case OP_CLOSURE_REF: - fprintf(stderr, "closure-ref %d => ", ((sexp*)ip)[0]); - fflush(stderr); - write_sexp(stderr, vector_ref(cp,((sexp*)ip)[0])); - fprintf(stderr, "\n"); - stack[top++]=vector_ref(cp,((sexp*)ip)[0]); - ip += sizeof(sexp); - break; -/* case OP_CLOSURE_SET: */ -/* cp[*ip++]=stack[--top]; */ -/* break; */ - case OP_VECTOR_REF: - stack[top-2]=vector_ref(stack[top-1], stack[top-2]); - top--; - break; - case OP_VECTOR_SET: - fprintf(stderr, "vector-set! %p %d => ", stack[top-1], unbox_integer(stack[top-2])); - write_sexp(stderr, stack[top-3]); - fprintf(stderr, "\n"); - vector_set(stack[top-1], stack[top-2], stack[top-3]); - stack[top-3]=SEXP_UNDEF; - top-=2; - break; - case OP_MAKE_PROCEDURE: - stack[top-2]=make_procedure(stack[top-1], stack[top-2]); - top--; - break; - case OP_MAKE_VECTOR: - stack[top-2]=make_vector(unbox_integer(stack[top-1]), stack[top-2]); - top--; - break; - case OP_PUSH: - /* fprintf(stderr, " (push)\n"); */ - stack[top++]=((sexp*)ip)[0]; - ip += sizeof(sexp); - break; - case OP_DUP: - stack[top]=stack[top-1]; - top++; - break; - case OP_DROP: - top--; - break; - case OP_SWAP: - tmp = stack[top-2]; - stack[top-2]=stack[top-1]; - stack[top-1]=tmp; - break; - case OP_CAR: - stack[top-1]=car(stack[top-1]); - break; - case OP_CDR: - stack[top-1]=cdr(stack[top-1]); - break; - case OP_SET_CAR: - set_car(stack[top-1], stack[top-2]); - stack[top-2]=SEXP_UNDEF; - top--; - break; - case OP_SET_CDR: - set_cdr(stack[top-1], stack[top-2]); - stack[top-2]=SEXP_UNDEF; - top--; - break; - case OP_CONS: - stack[top-2]=cons(stack[top-1], stack[top-2]); - top--; - break; - case OP_ADD: - fprintf(stderr, "OP_ADD %d %d\n", stack[top-1], stack[top-2]); - stack[top-2]=sexp_add(stack[top-1],stack[top-2]); - top--; - break; - case OP_SUB: - stack[top-2]=sexp_sub(stack[top-1],stack[top-2]); - top--; - break; - case OP_MUL: - stack[top-2]=sexp_mul(stack[top-2],stack[top-1]); - top--; - break; - case OP_DIV: - stack[top-2]=sexp_div(stack[top-2],stack[top-1]); - top--; - break; - case OP_MOD: - stack[top-2]=sexp_mod(stack[top-2],stack[top-1]); - top--; - break; - case OP_LT: - stack[top-2]=((stack[top-2] < stack[top-1]) ? SEXP_TRUE : SEXP_FALSE); - top--; - break; - case OP_CALL: - fprintf(stderr, "CALL\n"); - i = (unsigned long) ((sexp*)ip)[0]; - tmp = stack[top-1]; - if (! SEXP_PROCEDUREP(tmp)) - errx(2, "non-procedure application: %p", tmp); - stack[top-1] = (sexp) i; - stack[top] = (sexp) (ip+4); - stack[top+1] = cp; - top+=2; - bc = procedure_code(tmp); - print_bytecode(bc); - ip = bc->data; - cp = procedure_vars(tmp); - fprintf(stderr, "... calling procedure at %p\ncp: ", ip); - write_sexp(stderr, cp); - fprintf(stderr, "\n"); - /* print_stack(stack, top); */ - break; - case OP_JUMP_UNLESS: - fprintf(stderr, "JUMP UNLESS, stack top is %d\n", stack[top-1]); - if (stack[--top] == SEXP_FALSE) { - fprintf(stderr, "test passed, jumping to + %d => %d\n", ((signed char*)ip)[0], ip + ((signed char*)ip)[0]); - ip += ((signed char*)ip)[0]; - } else { - fprintf(stderr, "test failed, not jumping\n"); - ip++; - } - break; - case OP_JUMP: - fprintf(stderr, "jumping to + %d => %d\n", ((signed char*)ip)[0], ip + ((signed char*)ip)[0]); - ip += ((signed char*)ip)[0]; - break; - case OP_RET: - fprintf(stderr, "returning @ %d: ", top-1); - fflush(stderr); - write_sexp(stderr, stack[top-1]); - fprintf(stderr, "...\n"); - print_stack(stack, top); - /* top-1 */ - /* stack: args ... n ip result */ - cp = stack[top-2]; - fprintf(stderr, "1\n"); - ip = (unsigned char*) stack[top-3]; - fprintf(stderr, "2\n"); - i = unbox_integer(stack[top-4]); - fprintf(stderr, "3 (i=%d)\n", i); - stack[top-i-4] = stack[top-1]; - fprintf(stderr, "4\n"); - top = top-i-3; - fprintf(stderr, "... done returning\n"); - break; - case OP_DONE: - fprintf(stderr, "finally returning @ %d: ", top-1); - fflush(stderr); - write_sexp(stderr, stack[top-1]); - fprintf(stderr, "\n"); - goto end_loop; - default: - fprintf(stderr, "unknown opcode: %d\n", *(ip-1)); - stack[top] = SEXP_ERROR; - goto end_loop; - } - fprintf(stderr, "looping\n"); - goto loop; - - end_loop: - return stack[top-1]; -} - -bytecode compile(sexp params, sexp obj, env e, sexp fv, sexp sv, int done_p) { - unsigned int i = 0, j, d = 0; - bytecode bc = (bytecode) malloc(sizeof(struct bytecode)+INIT_BCODE_SIZE); - sexp sv2 = set_vars(e, params, obj, SEXP_NULL), ls; - fprintf(stderr, "set-vars: "); write_sexp(stderr, sv2); fprintf(stderr, "\n"); - bc->tag = SEXP_BYTECODE; - bc->len = INIT_BCODE_SIZE; - fprintf(stderr, "analyzing\n"); - for (ls=params; SEXP_PAIRP(ls); ls=SEXP_CDR(ls)) { - if ((j = list_index(sv2, SEXP_CAR(ls)) >= 0)) { - fprintf(stderr, "consing mutable var\n"); - emit(&bc, &i, OP_PUSH); - emit_word(&bc, &i, (unsigned long) SEXP_NULL); - emit(&bc, &i, OP_STACK_REF); - emit_word(&bc, &i, j+3); - emit(&bc, &i, OP_CONS); - emit(&bc, &i, OP_STACK_SET); - emit_word(&bc, &i, j+4); - emit(&bc, &i, OP_DROP); - } - } - sv = append(sv2, sv); - for ( ; SEXP_PAIRP(obj); obj=SEXP_CDR(obj)) { - fprintf(stderr, "loop: "); write_sexp(stderr, obj); fprintf(stderr, "\n"); - analyze(SEXP_CAR(obj), &bc, &i, e, params, fv, sv, &d); - if (SEXP_PAIRP(SEXP_CDR(obj))) emit(&bc, &i, OP_DROP); - } - emit(&bc, &i, done_p ? OP_DONE : OP_RET); - /* fprintf(stderr, "shrinking\n"); */ - shrink_bcode(&bc, i); - fprintf(stderr, "done compiling:\n"); - print_bytecode(bc); - disasm(bc); - return bc; -} - -sexp eval_in_stack(sexp obj, env e, sexp* stack, unsigned int top) { - bytecode bc = compile(SEXP_NULL, cons(obj, SEXP_NULL), e, SEXP_NULL, SEXP_NULL, 1); - fprintf(stderr, "evaling\n"); - return vm(bc, e, stack, top); -} - -sexp eval(sexp obj, env e) { - sexp* stack = (sexp*) malloc(sizeof(sexp) * INIT_STACK_SIZE); - sexp res = eval_in_stack(obj, e, stack, 0); - free(stack); - return res; -} - -int main (int argc, char **argv) { - sexp obj, res, *stack; - env e; - - sexp_init(); - e = make_standard_env(); - stack = (sexp*) malloc(sizeof(sexp) * INIT_STACK_SIZE); - - /* repl */ - fprintf(stdout, "> "); - fflush(stdout); - while ((obj = read_sexp(stdin)) != SEXP_EOF) { - write_sexp(stdout, obj); - fprintf(stdout, "\n => "); - res = eval_in_stack(obj, e, stack, 0); - /* fprintf(stderr, " (=> %d)\n", res); */ - write_sexp(stdout, res); - fprintf(stdout, "\n> "); - fflush(stdout); - } - fprintf(stdout, "\n"); - return 0; -} - diff --git a/sexp.h b/sexp.h new file mode 100644 index 00000000..abd26c7a --- /dev/null +++ b/sexp.h @@ -0,0 +1,195 @@ +/* sexp.h -- header for sexp library */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#ifndef SEXP_H +#define SEXP_H + +#include +#include +#include +#include + +#include "config.h" + +#ifdef HAVE_ERR_H +#include +#else +/* requires that msg be a string literal */ +#define errx(code, msg, ...) (fprintf(stderr,msg"\n",__VA_ARGS__), exit(code)) +#endif + +#define sexp_debug(msg, obj, ...) (fprintf(stderr,msg,__VA_ARGS__), fflush(stderr), write_sexp(stderr, obj), fprintf(stderr,"\n")) + +#ifdef USE_BOEHM +#include "gc/include/gc.h" +#define SEXP_ALLOC GC_malloc +#define SEXP_ALLOC_ATOMIC GC_malloc_atomic +#define SEXP_REALLOC GC_realloc +#define SEXP_FREE GC_free +#else +#define SEXP_ALLOC malloc +#define SEXP_ALLOC_ATOMIC SEXP_ALLOC +#define SEXP_REALLOC realloc +#define SEXP_FREE free +#endif + +#define SEXP_NEW() ((sexp) SEXP_ALLOC(sizeof(struct sexp_struct))) + +/* tagging system + * bits end in 00: pointer + * 01: fixnum + * 011: symbol + * 111: immediate symbol + * 0110: char + * 1110: other immediate object (NULL, TRUE, FALSE) + */ + +#define SEXP_FIXNUM_BITS 2 +#define SEXP_IMMEDIATE_BITS 3 +#define SEXP_EXTENDED_BITS 4 + +#define SEXP_FIXNUM_MASK 3 +#define SEXP_IMMEDIATE_MASK 7 +#define SEXP_EXTENDED_MASK 15 + +#define SEXP_POINTER_TAG 0 +#define SEXP_FIXNUM_TAG 1 +#define SEXP_LSYMBOL_TAG 3 +#define SEXP_ISYMBOL_TAG 7 +#define SEXP_CHAR_TAG 6 + +enum sexp_types { + SEXP_FIXNUM, + SEXP_CHAR, + SEXP_BOOLEAN, + SEXP_PAIR, + SEXP_SYMBOL, + SEXP_STRING, + SEXP_VECTOR, + /* the following are used only by the evaluator */ + SEXP_PROCEDURE, + SEXP_ENV, + SEXP_BYTECODE, + SEXP_CORE, + SEXP_OPCODE, +}; + +typedef struct sexp_struct { + char tag; + void *data1; + void *data2; +} *sexp; + +#define MAKE_IMMEDIATE(n) ((sexp) ((n<<4) + 14)) +#define SEXP_NULL MAKE_IMMEDIATE(0) +#define SEXP_FALSE MAKE_IMMEDIATE(1) +#define SEXP_TRUE MAKE_IMMEDIATE(2) +#define SEXP_EOF MAKE_IMMEDIATE(3) +#define SEXP_UNDEF MAKE_IMMEDIATE(4) +#define SEXP_ERROR MAKE_IMMEDIATE(5) +#define SEXP_CLOSE MAKE_IMMEDIATE(6) /* internal use */ +#define SEXP_RAWDOT MAKE_IMMEDIATE(7) /* internal use */ + +#define SEXP_NULLP(x) ((x) == SEXP_NULL) +#define SEXP_POINTERP(x) (((unsigned long)(x) & SEXP_FIXNUM_MASK) == SEXP_POINTER_TAG) +#define SEXP_INTEGERP(x) (((unsigned long)(x) & SEXP_FIXNUM_MASK) == SEXP_FIXNUM_TAG) +#define SEXP_ISYMBOLP(x) (((unsigned long)(x) & SEXP_IMMEDIATE_MASK) == SEXP_ISYMBOL_TAG) +#define SEXP_CHARP(x) (((unsigned long)(x) & SEXP_EXTENDED_MASK) == SEXP_CHAR_TAG) +#define SEXP_BOOLEANP(x) (((x) == SEXP_TRUE) || ((x) == SEXP_FALSE)) + +#define SEXP_PAIRP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_PAIR) +#define SEXP_STRINGP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_STRING) +#define SEXP_LSYMBOLP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_SYMBOL) +#define SEXP_VECTORP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_VECTOR) +#define SEXP_PROCEDUREP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_PROCEDURE) +#define SEXP_ENVP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_ENV) +#define SEXP_BYTECODEP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag ==SEXP_BYTECODE) +#define SEXP_COREP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_CORE) +#define SEXP_OPCODEP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_OPCODE) + +#define SEXP_SYMBOLP(x) (SEXP_ISYMBOLP(x) || SEXP_LSYMBOLP(x)) + +#ifdef USE_HUFF_SYMS +#define SEXP_DOTP(x) (((unsigned long)(x))==((0x5D00<>SEXP_FIXNUM_BITS) +#define make_character(n) ((sexp) (((long) n<>SEXP_EXTENDED_BITS) + +#define vector_length(x) ((unsigned long) x->data1) +#define vector_data(x) ((sexp*) x->data2) + +#define vector_ref(x, i) (vector_data(x)[unbox_integer(i)]) +#define vector_set(x, i, v) (vector_data(x)[unbox_integer(i)] = (v)) + +#define procedure_code(x) ((bytecode) ((sexp)x)->data1) +#define procedure_vars(x) ((sexp) ((sexp)x)->data2) + +#define string_length(x) ((unsigned long) x->data1) +#define string_data(x) ((char*) x->data2) + +#define symbol_pointer(x) ((sexp) (((unsigned long)x)-SEXP_LSYMBOL_TAG)) +#define symbol_length(x) ((unsigned long) (symbol_pointer(x)->data1)) +#define symbol_data(x) ((char*) (symbol_pointer(x)->data2)) + +#define sexp_add(a, b) ((sexp)(((unsigned long)a)+((unsigned long)b)-SEXP_FIXNUM_TAG)) +#define sexp_sub(a, b) ((sexp)(((unsigned long)a)-((unsigned long)b)+SEXP_FIXNUM_TAG)) +#define sexp_mul(a, b) ((sexp)((((((unsigned long)a)-SEXP_FIXNUM_TAG)*(((unsigned long)b)>>SEXP_FIXNUM_BITS))+SEXP_FIXNUM_TAG))) +#define sexp_div(a, b) ((sexp)(((((unsigned long)a)>>SEXP_FIXNUM_BITS)/(((unsigned long)b)>>SEXP_FIXNUM_BITS))<>SEXP_FIXNUM_BITS)%(((unsigned long)b)>>SEXP_FIXNUM_BITS))<data1) +#define SEXP_CDR(x) (((sexp)x)->data2) + +#define SEXP_CAAR(x) (SEXP_CAR(SEXP_CAR(x))) +#define SEXP_CADR(x) (SEXP_CAR(SEXP_CDR(x))) +#define SEXP_CDAR(x) (SEXP_CDR(SEXP_CAR(x))) +#define SEXP_CDDR(x) (SEXP_CDR(SEXP_CDR(x))) + +#define SEXP_CADDR(x) (SEXP_CAR(SEXP_CDDR(x))) +#define SEXP_CDDDR(x) (SEXP_CDR(SEXP_CDDR(x))) +#define SEXP_CADDDR(x) (SEXP_CADR(SEXP_CDDR(x))) +#define SEXP_CDDDDR(x) (SEXP_CDDR(SEXP_CDDR(x))) + +sexp cons(sexp head, sexp tail); +sexp car(sexp obj); +sexp cdr(sexp obj); +sexp set_car(sexp obj, sexp val); +sexp set_cdr(sexp obj, sexp val); + +int listp(sexp obj); +int list_index(sexp ls, sexp elt); +sexp lset_diff(sexp a, sexp b); +sexp reverse(sexp ls); +sexp nreverse(sexp ls); +sexp append(sexp a, sexp b); +sexp list(int count, ...); +sexp memq(sexp x, sexp ls); +sexp assq (sexp x, sexp ls); +unsigned long length(sexp ls); +sexp make_string(char *str); +int string_hash(char *str, int acc); +sexp intern(char *str); +sexp make_vector(unsigned long len, sexp dflt); +sexp list_to_vector(sexp ls); +sexp vector(int count, ...); +void write_sexp(FILE *out, sexp obj); +void free_sexp(sexp obj); +char* read_string(FILE *in); +char* read_symbol(FILE *in, int init); +int read_number(FILE *in); +sexp read_sexp_raw(FILE *in); +sexp read_sexp(FILE *in); +void sexp_init(); + +#endif /* ! SEXP_H */ + From d609e52e5f4394963ef87c313167c448c79c8333 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 3 Mar 2009 21:41:20 +0900 Subject: [PATCH 009/154] using boehm gc by default --- Makefile | 4 ++-- eval.c | 18 +++++++++--------- sexp.c | 3 +++ 3 files changed, 14 insertions(+), 11 deletions(-) diff --git a/Makefile b/Makefile index d352a6d5..1c5154e4 100644 --- a/Makefile +++ b/Makefile @@ -8,10 +8,10 @@ GC_OBJ=./gc/gc.a $GC_OBJ: ./gc/alloc.c cd gc && make test -sexp.o: sexp.c sexp.h +sexp.o: sexp.c sexp.h config.h gcc -c -g -Os -o $@ $< -eval.o: eval.c eval.h sexp.h +eval.o: eval.c debug.c eval.h sexp.h config.h gcc -c -g -Os -o $@ $< chibi-scheme: sexp.o eval.o $(GC_OBJ) diff --git a/eval.c b/eval.c index a5c24a12..7f7f4afa 100644 --- a/eval.c +++ b/eval.c @@ -79,7 +79,7 @@ void env_define(env e, sexp key, sexp value) { env extend_env_closure (env e, sexp fv) { int i; - env e2 = (env) malloc(sizeof(struct env)); + env e2 = (env) SEXP_ALLOC(sizeof(struct env)); e2->tag = SEXP_ENV; e2->parent = e; e2->bindings = SEXP_NULL; @@ -91,7 +91,7 @@ env extend_env_closure (env e, sexp fv) { env make_standard_env() { int i; - env e = (env) malloc(sizeof(struct env)); + env e = (env) SEXP_ALLOC(sizeof(struct env)); e->tag = SEXP_ENV; e->parent = NULL; e->bindings = SEXP_NULL; @@ -110,7 +110,7 @@ void shrink_bcode(bytecode *bc, unsigned int i) { bytecode tmp; if ((*bc)->len != i) { fprintf(stderr, "shrinking to %d\n", i); - tmp = (bytecode) malloc(sizeof(struct bytecode) + i); + tmp = (bytecode) SEXP_ALLOC(sizeof(struct bytecode) + i); tmp->tag = SEXP_BYTECODE; tmp->len = i; memcpy(tmp->data, (*bc)->data, i); @@ -123,7 +123,7 @@ void emit(bytecode *bc, unsigned int *i, char c) { bytecode tmp; if ((*bc)->len < (*i)+1) { fprintf(stderr, "expanding (%d < %d)\n", (*bc)->len, (*i)+1); - tmp = (bytecode) malloc(sizeof(unsigned int) + (*bc)->len*2); + tmp = (bytecode) SEXP_ALLOC(sizeof(unsigned int) + (*bc)->len*2); tmp->len = (*bc)->len*2; memcpy(tmp->data, (*bc)->data, (*bc)->len); SEXP_FREE(*bc); @@ -135,7 +135,7 @@ void emit(bytecode *bc, unsigned int *i, char c) { void emit_word(bytecode *bc, unsigned int *i, unsigned long val) { bytecode tmp; if ((*bc)->len < (*i)+4) { - tmp = (bytecode) malloc(sizeof(unsigned int) + (*bc)->len*2); + tmp = (bytecode) SEXP_ALLOC(sizeof(unsigned int) + (*bc)->len*2); tmp->len = (*bc)->len*2; memcpy(tmp->data, (*bc)->data, (*bc)->len); SEXP_FREE(*bc); @@ -440,7 +440,7 @@ void analyze_lambda (sexp name, sexp formals, sexp body, bytecode compile(sexp params, sexp obj, env e, sexp fv, sexp sv, int done_p) { unsigned int i = 0, j, d = 0; - bytecode bc = (bytecode) malloc(sizeof(struct bytecode)+INIT_BCODE_SIZE); + bytecode bc = (bytecode) SEXP_ALLOC(sizeof(struct bytecode)+INIT_BCODE_SIZE); sexp sv2 = set_vars(e, params, obj, SEXP_NULL), ls; fprintf(stderr, "set-vars: "); write_sexp(stderr, sv2); fprintf(stderr, "\n"); bc->tag = SEXP_BYTECODE; @@ -689,9 +689,9 @@ sexp eval_in_stack(sexp obj, env e, sexp* stack, unsigned int top) { } sexp eval(sexp obj, env e) { - sexp* stack = (sexp*) malloc(sizeof(sexp) * INIT_STACK_SIZE); + sexp* stack = (sexp*) SEXP_ALLOC(sizeof(sexp) * INIT_STACK_SIZE); sexp res = eval_in_stack(obj, e, stack, 0); - free(stack); + SEXP_FREE(stack); return res; } @@ -701,7 +701,7 @@ int main (int argc, char **argv) { sexp_init(); e = make_standard_env(); - stack = (sexp*) malloc(sizeof(sexp) * INIT_STACK_SIZE); + stack = (sexp*) SEXP_ALLOC(sizeof(sexp) * INIT_STACK_SIZE); /* repl */ fprintf(stdout, "> "); diff --git a/sexp.c b/sexp.c index 1d09e158..5a24b841 100644 --- a/sexp.c +++ b/sexp.c @@ -672,6 +672,9 @@ sexp read_sexp (FILE *in) { void sexp_init() { if (! initialized_p) { initialized_p = 1; +#ifdef USE_BOEHM + GC_init(); +#endif symbol_table = SEXP_ALLOC(symbol_table_primes[0]*sizeof(sexp)); the_dot_symbol = intern("."); the_quote_symbol = intern("quote"); From abecbd70f0fc03bd44e89dfdd7f50499dfc7ee6a Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Wed, 4 Mar 2009 00:21:17 +0900 Subject: [PATCH 010/154] fixing offby1 error in closure rep --- Makefile | 8 +- eval.c | 54 ++--- eval.h | 6 + sexp-orig.c | 594 ---------------------------------------------------- sexp.c | 4 +- sexp.h | 2 +- 6 files changed, 42 insertions(+), 626 deletions(-) delete mode 100644 sexp-orig.c diff --git a/Makefile b/Makefile index 1c5154e4..65bd0c22 100644 --- a/Makefile +++ b/Makefile @@ -3,19 +3,21 @@ all: chibi-scheme +CFLAGS=-g -Os + GC_OBJ=./gc/gc.a $GC_OBJ: ./gc/alloc.c cd gc && make test sexp.o: sexp.c sexp.h config.h - gcc -c -g -Os -o $@ $< + gcc -c $(CFLAGS) -o $@ $< eval.o: eval.c debug.c eval.h sexp.h config.h - gcc -c -g -Os -o $@ $< + gcc -c $(CFLAGS) -o $@ $< chibi-scheme: sexp.o eval.o $(GC_OBJ) - gcc -g -Os -o $@ $^ + gcc $(CFLAGS) -o $@ $^ clean: rm -f *.o diff --git a/eval.c b/eval.c index 7f7f4afa..8d39dedb 100644 --- a/eval.c +++ b/eval.c @@ -4,7 +4,7 @@ #include "eval.h" -/* ******************************************************************** */ +/************************************************************************/ static struct core_form core_forms[] = { {SEXP_CORE, "define", CORE_DEFINE}, @@ -19,17 +19,19 @@ static struct core_form core_forms[] = { }; static struct opcode opcodes[] = { -{SEXP_OPCODE, OPC_TYPE_PREDICATE, OP_CAR, 1, 0, SEXP_PAIR, 0, "car", 0, NULL}, -{SEXP_OPCODE, OPC_TYPE_PREDICATE, OP_CDR, 1, 0, SEXP_PAIR, 0, "cdr", 0, NULL}, -{SEXP_OPCODE, OPC_ARITHMETIC, OP_ADD, 0, 1, SEXP_FIXNUM, 0, "+", 0, NULL}, -{SEXP_OPCODE, OPC_ARITHMETIC_INV, OP_SUB, 0, 1, SEXP_FIXNUM, 0, "-", OP_NEG, NULL}, -{SEXP_OPCODE, OPC_ARITHMETIC, OP_MUL, 0, 1, SEXP_FIXNUM, 0, "*", 0, NULL}, -{SEXP_OPCODE, OPC_ARITHMETIC_INV, OP_DIV, 0, 1, SEXP_FIXNUM, 0, "/", OP_INV, 0}, -{SEXP_OPCODE, OPC_ARITHMETIC, OP_MOD, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, "%", 0, NULL}, -{SEXP_OPCODE, OPC_ARITHMETIC_CMP, OP_LT, 0, 1, SEXP_FIXNUM, 0, "<", 0, NULL}, -{SEXP_OPCODE, OPC_CONSTRUCTOR, OP_CONS, 2, 0, 0, 0, "cons", 0, NULL}, -{SEXP_OPCODE, OPC_CONSTRUCTOR, OP_MAKE_VECTOR, 2, 0, SEXP_FIXNUM, 0, "make-vector", 0, NULL}, -{SEXP_OPCODE, OPC_CONSTRUCTOR, OP_MAKE_PROCEDURE, 2, 0, 0, 0, "make-procedure", 0, NULL}, +#define _OP(c,o,n,m,t,u,s,i) {SEXP_OPCODE, c, o, n, m, t, u, s, i, NULL} +_OP(OPC_TYPE_PREDICATE, OP_CAR, 1, 0, SEXP_PAIR, 0, "car", 0), +_OP(OPC_TYPE_PREDICATE, OP_CDR, 1, 0, SEXP_PAIR, 0, "cdr", 0), +_OP(OPC_ARITHMETIC, OP_ADD, 0, 1, SEXP_FIXNUM, 0, "+", 0), +_OP(OPC_ARITHMETIC_INV, OP_SUB, 0, 1, SEXP_FIXNUM, 0, "-", OP_NEG), +_OP(OPC_ARITHMETIC, OP_MUL, 0, 1, SEXP_FIXNUM, 0, "*", 0), +_OP(OPC_ARITHMETIC_INV, OP_DIV, 0, 1, SEXP_FIXNUM, 0, "/", OP_INV), +_OP(OPC_ARITHMETIC, OP_MOD, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, "%", 0), +_OP(OPC_ARITHMETIC_CMP, OP_LT, 0, 1, SEXP_FIXNUM, 0, "<", 0), +_OP(OPC_CONSTRUCTOR, OP_CONS, 2, 0, 0, 0, "cons", 0), +_OP(OPC_CONSTRUCTOR, OP_MAKE_VECTOR, 2, 0, SEXP_FIXNUM, 0, "make-vector", 0), +_OP(OPC_CONSTRUCTOR, OP_MAKE_PROCEDURE, 2, 0, 0, 0, "make-procedure", 0), +#undef _OP }; #ifdef USE_DEBUG @@ -145,6 +147,8 @@ void emit_word(bytecode *bc, unsigned int *i, unsigned long val) { *i += sizeof(unsigned long); } +#define emit_push(bc,i,obj) (emit(bc,i,OP_PUSH), emit_word(bc,i,(unsigned long)obj)) + sexp make_procedure(sexp bc, sexp vars) { sexp proc = SEXP_NEW(); if (! proc) return SEXP_ERROR; @@ -409,8 +413,7 @@ sexp set_vars (env e, sexp formals, sexp obj, sexp sv) { void analyze_lambda (sexp name, sexp formals, sexp body, bytecode *bc, unsigned int *i, env e, sexp params, sexp fv, sexp sv, unsigned int *d) { - sexp obj; - sexp fv2 = free_vars(e, formals, body, SEXP_NULL), ls; + sexp obj, ls, fv2 = free_vars(e, formals, body, SEXP_NULL); env e2 = extend_env_closure(e, formals); int k; fprintf(stderr, "%d free-vars\n", length(fv2)); @@ -452,7 +455,7 @@ bytecode compile(sexp params, sexp obj, env e, sexp fv, sexp sv, int done_p) { emit(&bc, &i, OP_PUSH); emit_word(&bc, &i, (unsigned long) SEXP_NULL); emit(&bc, &i, OP_STACK_REF); - emit_word(&bc, &i, j+3); + emit_word(&bc, &i, j+4); emit(&bc, &i, OP_CONS); emit(&bc, &i, OP_STACK_SET); emit_word(&bc, &i, j+4); @@ -466,7 +469,6 @@ bytecode compile(sexp params, sexp obj, env e, sexp fv, sexp sv, int done_p) { if (SEXP_PAIRP(SEXP_CDR(obj))) emit(&bc, &i, OP_DROP); } emit(&bc, &i, done_p ? OP_DONE : OP_RET); - /* fprintf(stderr, "shrinking\n"); */ shrink_bcode(&bc, i); fprintf(stderr, "done compiling:\n"); print_bytecode(bc); @@ -482,7 +484,7 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { int i; loop: - /* fprintf(stderr, "opcode: %d, ip: %d\n", *ip, ip); */ + /* fprintf(stderr, "opcode: %s (%d), ip: %d\n", reverse_opcode_names[*ip], *ip, ip); */ /* print_bytecode(bc); */ switch (*ip++) { case OP_NOOP: @@ -617,17 +619,19 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { if (! SEXP_PROCEDUREP(tmp)) errx(2, "non-procedure application: %p", tmp); stack[top-1] = (sexp) i; - stack[top] = (sexp) (ip+4); + stack[top] = make_integer(ip+4); stack[top+1] = cp; top+=2; bc = procedure_code(tmp); print_bytecode(bc); + disasm(bc); ip = bc->data; cp = procedure_vars(tmp); fprintf(stderr, "... calling procedure at %p\ncp: ", ip); write_sexp(stderr, cp); fprintf(stderr, "\n"); - /* print_stack(stack, top); */ + fprintf(stderr, "stack at %d\n", top); + print_stack(stack, top); break; case OP_JUMP_UNLESS: fprintf(stderr, "JUMP UNLESS, stack top is %d\n", stack[top-1]); @@ -652,13 +656,9 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { /* top-1 */ /* stack: args ... n ip result */ cp = stack[top-2]; - fprintf(stderr, "1\n"); - ip = (unsigned char*) stack[top-3]; - fprintf(stderr, "2\n"); + ip = (unsigned char*) unbox_integer(stack[top-3]); i = unbox_integer(stack[top-4]); - fprintf(stderr, "3 (i=%d)\n", i); stack[top-i-4] = stack[top-1]; - fprintf(stderr, "4\n"); top = top-i-3; fprintf(stderr, "... done returning\n"); break; @@ -673,7 +673,7 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { stack[top] = SEXP_ERROR; goto end_loop; } - fprintf(stderr, "looping\n"); + /* print_stack(stack, top); */ goto loop; end_loop: @@ -683,8 +683,8 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { /************************** eval interface ****************************/ sexp eval_in_stack(sexp obj, env e, sexp* stack, unsigned int top) { - bytecode bc = compile(SEXP_NULL, cons(obj, SEXP_NULL), e, SEXP_NULL, SEXP_NULL, 1); - fprintf(stderr, "evaling\n"); + bytecode bc; + bc = compile(SEXP_NULL, cons(obj, SEXP_NULL), e, SEXP_NULL, SEXP_NULL, 1); return vm(bc, e, stack, top); } diff --git a/eval.h b/eval.h index f8c806e6..a1596c9d 100644 --- a/eval.h +++ b/eval.h @@ -107,6 +107,7 @@ enum opcode_names { /**************************** prototypes ******************************/ bytecode compile(sexp params, sexp obj, env e, sexp fv, sexp sv, int done_p); + void analyze_app (sexp obj, bytecode *bc, unsigned int *i, env e, sexp params, sexp fv, sexp sv, unsigned int *d); void analyze_lambda (sexp name, sexp formals, sexp body, @@ -115,5 +116,10 @@ void analyze_lambda (sexp name, sexp formals, sexp body, void analyze_var_ref (sexp name, bytecode *bc, unsigned int *i, env e, sexp params, sexp fv, sexp sv, unsigned int *d); +sexp vm(bytecode bc, env e, sexp* stack, unsigned int top); + +sexp eval_in_stack(sexp obj, env e, sexp* stack, unsigned int top); +sexp eval(sexp obj, env e); + #endif /* ! SCM_EVAL_H */ diff --git a/sexp-orig.c b/sexp-orig.c deleted file mode 100644 index 1da4500a..00000000 --- a/sexp-orig.c +++ /dev/null @@ -1,594 +0,0 @@ - -/* #include */ -#include -#include -#include -#include - -/* simple tagging - * ends in 00: pointer - * 1: fixnum - * 010: symbol - * 0110: char - * 1110: other immediate object (NULL, TRUE, FALSE) - */ - -enum sexp_tags { - SEXP_PAIR, - SEXP_SYMBOL, - SEXP_STRING, - SEXP_VECTOR, -}; - -/* would need a proper header for GC */ -typedef struct sexp_struct { - char tag; - void *data1; - void *data2; -} *sexp; - -#define MAKE_IMMEDIATE(n) ((sexp) ((n<<3) + 6)) -#define SEXP_NULL MAKE_IMMEDIATE(0) -#define SEXP_FALSE MAKE_IMMEDIATE(1) -#define SEXP_TRUE MAKE_IMMEDIATE(2) -#define SEXP_EOF MAKE_IMMEDIATE(3) -#define SEXP_UNDEF MAKE_IMMEDIATE(4) -#define SEXP_CLOSE MAKE_IMMEDIATE(5) /* internal use */ -#define SEXP_ERROR MAKE_IMMEDIATE(6) - -#define SEXP_NULLP(x) ((x) == SEXP_NULL) -#define SEXP_POINTERP(x) (((int) x & 3) == 0) -#define SEXP_INTEGERP(x) (((int) x & 3) == 1) -#define SEXP_CHARP(x) (((int) x & 7) == 2) - -#define SEXP_PAIRP(x) (SEXP_POINTERP(x) && (x)->tag == SEXP_PAIR) -#define SEXP_SYMBOLP(x) (SEXP_POINTERP(x) && (x)->tag == SEXP_SYMBOL) -#define SEXP_STRINGP(x) (SEXP_POINTERP(x) && (x)->tag == SEXP_STRING) - -#define SEXP_ALLOC(size) (malloc(size)) -#define SEXP_FREE free -#define SEXP_NEW() ((sexp) SEXP_ALLOC(sizeof(sexp))) - -#define make_integer(n) ((sexp) (((int) n<<2) + 1)) -#define unbox_integer(n) ((int) n>>2) -#define make_character(n) ((sexp) (((int) n<<3) + 2)) -#define unbox_character(n) ((int) n>>3) - -#define vector_length(x) ((int) x->data1) -#define vector_data(x) ((sexp*) x->data2) - -#define string_length(x) ((int) x->data1) -#define string_data(x) ((char*) x->data2) - -sexp cons(sexp head, sexp tail) { - sexp pair = SEXP_NEW(); - if (! pair) return SEXP_ERROR; - pair->tag = SEXP_PAIR; - pair->data1 = (void*) head; - pair->data2 = (void*) tail; - return pair; -} - -sexp car(sexp obj) { - return (SEXP_PAIRP(obj)) ? obj->data1 : SEXP_ERROR; -} - -sexp cdr(sexp obj) { - return (SEXP_PAIRP(obj)) ? obj->data2 : SEXP_ERROR; -} - -sexp set_car(sexp obj, sexp val) { - if (SEXP_PAIRP(obj)) { - return obj->data1 = val; - } else { - return SEXP_ERROR; - } -} - -sexp set_cdr(sexp obj, sexp val) { - if (SEXP_PAIRP(obj)) { - return obj->data2 = val; - } else { - return SEXP_ERROR; - } -} - -sexp nreverse(sexp ls) { - sexp a; - sexp b; - sexp tmp; - - if (ls == SEXP_NULL) { - return ls; - } else if (! SEXP_PAIRP(ls)) { - return SEXP_ERROR; - } else { - b = ls; - a=cdr(ls); - set_cdr(b, SEXP_NULL); - for ( ; SEXP_PAIRP(a); ) { - tmp = cdr(a); - set_cdr(a, b); - b = a; - a = tmp; - } - return b; - } -} - -sexp list(int count, ...) { - sexp res = SEXP_NULL; - sexp elt; - int i; - va_list ap; - - va_start(ap, count); - for (i=0; itag = SEXP_STRING; - s->data1 = (void*) len; - s->data2 = (void*) mystr; - return s; -} - -sexp intern(char *str) { - sexp sym = SEXP_NEW(); - if (! sym) return SEXP_ERROR; - int len = strlen(str); - char *mystr = SEXP_ALLOC(len+1); - if (! mystr) { SEXP_FREE(sym); return SEXP_ERROR; } - strncpy(mystr, str, len+1); - sym->tag = SEXP_SYMBOL; - sym->data1 = (void*) len; - sym->data2 = (void*) mystr; - return sym; -} - -sexp make_vector(int len, sexp dflt) { - int i; - sexp v = SEXP_NEW(); - if (v == NULL) return SEXP_ERROR; - sexp *x = (void*) SEXP_ALLOC(len*sizeof(sexp)); - if (x == NULL) return SEXP_ERROR; - for (i=0; itag = SEXP_VECTOR; - v->data1 = (void*) len; - v->data2 = (void*) x; - return v; -} - -sexp list_to_vector(sexp ls) { - sexp vec = make_vector(length(ls), SEXP_FALSE); - if (vec == SEXP_ERROR) return vec; - sexp x; - sexp *elts = vector_data(vec); - int i; - for (i=0, x=ls; SEXP_PAIRP(x); i++, x=cdr(x)) { - elts[i] = car(x); - } - return vec; -} - -sexp vector(int count, ...) { - sexp vec = make_vector(count, SEXP_FALSE); - if (vec == SEXP_ERROR) return vec; - sexp *elts = vector_data(vec); - va_list ap; - int i; - - va_start(ap, count); - for (i=0; itag) { - case SEXP_PAIR: - fprintf(out, "("); - write_sexp(out, car(obj)); - for (x=cdr(obj); SEXP_PAIRP(x); x=cdr(x)) { - fprintf(out, " "); - write_sexp(out, car(x)); - } - if (! SEXP_NULLP(x)) { - fprintf(out, " . "); - write_sexp(out, x); - } - fprintf(out, ")"); - break; - case SEXP_VECTOR: - len = vector_length(obj); - sexp *elts = vector_data(obj); - if (len == 0) { - fprintf(out, "#()"); - } else { - fprintf(out, "#("); - write_sexp(out, elts[0]); - for (i=1; itag == SEXP_STRING) { - fprintf(out, "\""); - } - break; - } - - } else if (SEXP_INTEGERP(obj)) { - - fprintf(out, "%d", unbox_integer(obj)); - - } else if (SEXP_CHARP(obj)) { - - if (33 <= unbox_character(obj) < 127) { - fprintf(out, "#\\%c", unbox_character(obj)); - } else { - fprintf(out, "#\\x%02d", unbox_character(obj)); - } - - } else { - - switch ((int) obj) { - case (int) SEXP_NULL: - fprintf(out, "()"); - break; - case (int) SEXP_TRUE: - fprintf(out, "#t"); - break; - case (int) SEXP_FALSE: - fprintf(out, "#f"); - break; - case (int) SEXP_EOF: - fprintf(out, "#"); - break; - case (int) SEXP_UNDEF: - fprintf(out, "#"); - break; - default: - fprintf(out, "#"); - } - } -} - -void* free_sexp (sexp obj) { - int len, i; - sexp *elts; - - if (SEXP_POINTERP(obj)) { - switch (obj->tag) { - case SEXP_PAIR: - free_sexp(car(obj)); - free_sexp(cdr(obj)); - break; - case SEXP_VECTOR: - len = vector_length(obj); - elts = vector_data(obj); - for (i=0; i "); - fflush(stdout); - while ((obj = read_sexp(stdin)) != SEXP_EOF) { - write_sexp(stdout, obj); - fprintf(stdout, "\n> "); - fflush(stdout); - } - fprintf(stdout, "\n"); - return 0; -} diff --git a/sexp.c b/sexp.c index 5a24b841..8e4b5535 100644 --- a/sexp.c +++ b/sexp.c @@ -102,8 +102,10 @@ sexp cdr(sexp obj) { sexp set_car(sexp obj, sexp val) { if (SEXP_PAIRP(obj)) return SEXP_CAR(obj) = val; - else + else { + sexp_debug("error: set-car! not a pair: ", obj); return SEXP_ERROR; + } } sexp set_cdr(sexp obj, sexp val) { diff --git a/sexp.h b/sexp.h index abd26c7a..e2b88fa4 100644 --- a/sexp.h +++ b/sexp.h @@ -19,7 +19,7 @@ #define errx(code, msg, ...) (fprintf(stderr,msg"\n",__VA_ARGS__), exit(code)) #endif -#define sexp_debug(msg, obj, ...) (fprintf(stderr,msg,__VA_ARGS__), fflush(stderr), write_sexp(stderr, obj), fprintf(stderr,"\n")) +#define sexp_debug(msg, obj) (fprintf(stderr,msg), fflush(stderr), write_sexp(stderr, obj), fprintf(stderr,"\n")) #ifdef USE_BOEHM #include "gc/include/gc.h" From eafc5f2136e1ad2cfe79130adc7b02ce3a3c08dc Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Wed, 4 Mar 2009 02:16:01 +0900 Subject: [PATCH 011/154] initial float support, more opcodes --- debug.c | 14 +-- eval.c | 267 ++++++++++++++++++++++++++++++++++---------------------- eval.h | 60 ++++++++----- sexp.c | 108 ++++++++++++++--------- sexp.h | 43 +++++---- 5 files changed, 300 insertions(+), 192 deletions(-) diff --git a/debug.c b/debug.c index cded6223..dfab37f8 100644 --- a/debug.c +++ b/debug.c @@ -3,12 +3,13 @@ /* BSD-style license: http://synthcode.com/license.txt */ static const char* reverse_opcode_names[] = - {"NOOP", "STACK_REF", "STACK_SET", "GLOBAL_REF", "GLOBAL_SET", "CLOSURE_REF", - "CLOSURE_SET", "VECTOR_REF", "VECTOR_SET", "MAKE_PROCEDURE", "MAKE_VECTOR", - "PUSH", "DUP", "DROP", "SWAP", "CAR", "CDR", "SET_CAR", "SET_CDR", "CONS", - "ADD", "SUB", "MUL", "DIV", "MOD", "NEG", "INV", "LT", "CALL", - "JUMP_UNLESS", "JUMP", "RET", "DONE" - }; + {"NOOP", "CALL", "JUMP_UNLESS", "JUMP", "RET", "DONE", "STACK_REF", + "STACK_SET", "GLOBAL_REF", "GLOBAL_SET", "CLOSURE_REF", "VECTOR_REF", + "VECTOR_SET", "STRING_REF", "STRING_SET", "MAKE_PROCEDURE", "MAKE_VECTOR", + "PUSH", "DUP", "DROP", "SWAP", "PAIRP", "NULLP", "VECTORP", "INTEGERP", + "SYMBOLP", "STRINGP", "CHARP", "EOFP", "PROCEDUREP", "CAR", "CDR", + "SET_CAR", "SET_CDR", "CONS", "ADD", "SUB", "MUL", "DIV", "MOD", "NEG", + "INV", "LT", "LE", "GT", "GE", "EQN", "EQ"}; void disasm (bytecode bc) { unsigned char *ip=bc->data, opcode; @@ -23,7 +24,6 @@ void disasm (bytecode bc) { case OP_STACK_REF: case OP_STACK_SET: case OP_CLOSURE_REF: - case OP_CLOSURE_SET: fprintf(stderr, "%d", (long) ((sexp*)ip)[0]); ip += sizeof(sexp); break; diff --git a/eval.c b/eval.c index 8d39dedb..164984ab 100644 --- a/eval.c +++ b/eval.c @@ -20,17 +20,36 @@ static struct core_form core_forms[] = { static struct opcode opcodes[] = { #define _OP(c,o,n,m,t,u,s,i) {SEXP_OPCODE, c, o, n, m, t, u, s, i, NULL} -_OP(OPC_TYPE_PREDICATE, OP_CAR, 1, 0, SEXP_PAIR, 0, "car", 0), -_OP(OPC_TYPE_PREDICATE, OP_CDR, 1, 0, SEXP_PAIR, 0, "cdr", 0), +_OP(OPC_ACCESSOR, OP_CAR, 1, 0, SEXP_PAIR, 0, "car",0), +_OP(OPC_ACCESSOR, OP_SET_CAR, 2, 0, SEXP_PAIR, 0, "set-car!",0), +_OP(OPC_ACCESSOR, OP_CDR, 1, 0, SEXP_PAIR, 0, "cdr",0), +_OP(OPC_ACCESSOR, OP_SET_CDR, 2, 0, SEXP_PAIR, 0, "set-cdr!",0), +_OP(OPC_ACCESSOR, OP_VECTOR_REF,2,0, SEXP_VECTOR, SEXP_FIXNUM, "vector-ref",0), +_OP(OPC_ACCESSOR, OP_VECTOR_SET,3,0, SEXP_VECTOR, SEXP_FIXNUM, "vector-set!",0), +_OP(OPC_ACCESSOR, OP_STRING_REF,2,0, SEXP_STRING, SEXP_FIXNUM, "string-ref",0), +_OP(OPC_ACCESSOR, OP_STRING_SET,3,0, SEXP_STRING, SEXP_FIXNUM, "string-set!",0), _OP(OPC_ARITHMETIC, OP_ADD, 0, 1, SEXP_FIXNUM, 0, "+", 0), _OP(OPC_ARITHMETIC_INV, OP_SUB, 0, 1, SEXP_FIXNUM, 0, "-", OP_NEG), _OP(OPC_ARITHMETIC, OP_MUL, 0, 1, SEXP_FIXNUM, 0, "*", 0), _OP(OPC_ARITHMETIC_INV, OP_DIV, 0, 1, SEXP_FIXNUM, 0, "/", OP_INV), _OP(OPC_ARITHMETIC, OP_MOD, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, "%", 0), _OP(OPC_ARITHMETIC_CMP, OP_LT, 0, 1, SEXP_FIXNUM, 0, "<", 0), +_OP(OPC_ARITHMETIC_CMP, OP_LE, 0, 1, SEXP_FIXNUM, 0, "<=", 0), +_OP(OPC_ARITHMETIC_CMP, OP_GT, 0, 1, SEXP_FIXNUM, 0, ">", 0), +_OP(OPC_ARITHMETIC_CMP, OP_GE, 0, 1, SEXP_FIXNUM, 0, ">=", 0), +_OP(OPC_ARITHMETIC_CMP, OP_EQN, 0, 1, SEXP_FIXNUM, 0, "=", 0), +_OP(OPC_PREDICATE, OP_EQ, 2, 0, 0, 0, "eq?", 0), _OP(OPC_CONSTRUCTOR, OP_CONS, 2, 0, 0, 0, "cons", 0), _OP(OPC_CONSTRUCTOR, OP_MAKE_VECTOR, 2, 0, SEXP_FIXNUM, 0, "make-vector", 0), _OP(OPC_CONSTRUCTOR, OP_MAKE_PROCEDURE, 2, 0, 0, 0, "make-procedure", 0), +_OP(OPC_TYPE_PREDICATE, OP_PAIRP, 1, 0, 0, 0, "pair?", 0), +_OP(OPC_TYPE_PREDICATE, OP_NULLP, 1, 0, 0, 0, "null?", 0), +_OP(OPC_TYPE_PREDICATE, OP_STRINGP, 1, 0, 0, 0, "string?", 0), +_OP(OPC_TYPE_PREDICATE, OP_SYMBOLP, 1, 0, 0, 0, "symbol?", 0), +_OP(OPC_TYPE_PREDICATE, OP_CHARP, 1, 0, 0, 0, "char?", 0), +_OP(OPC_TYPE_PREDICATE, OP_VECTORP, 1, 0, 0, 0, "vector?", 0), +_OP(OPC_TYPE_PREDICATE, OP_PROCEDUREP, 1, 0, 0, 0, "procedure?", 0), +_OP(OPC_TYPE_PREDICATE, OP_EOFP, 1, 0, 0, 0, "eof-object?", 0), #undef _OP }; @@ -111,7 +130,7 @@ env make_standard_env() { void shrink_bcode(bytecode *bc, unsigned int i) { bytecode tmp; if ((*bc)->len != i) { - fprintf(stderr, "shrinking to %d\n", i); + /* fprintf(stderr, "shrinking to %d\n", i); */ tmp = (bytecode) SEXP_ALLOC(sizeof(struct bytecode) + i); tmp->tag = SEXP_BYTECODE; tmp->len = i; @@ -124,7 +143,7 @@ void shrink_bcode(bytecode *bc, unsigned int i) { void emit(bytecode *bc, unsigned int *i, char c) { bytecode tmp; if ((*bc)->len < (*i)+1) { - fprintf(stderr, "expanding (%d < %d)\n", (*bc)->len, (*i)+1); + /* fprintf(stderr, "expanding (%d < %d)\n", (*bc)->len, (*i)+1); */ tmp = (bytecode) SEXP_ALLOC(sizeof(unsigned int) + (*bc)->len*2); tmp->len = (*bc)->len*2; memcpy(tmp->data, (*bc)->data, (*bc)->len); @@ -134,7 +153,7 @@ void emit(bytecode *bc, unsigned int *i, char c) { (*bc)->data[(*i)++] = c; } -void emit_word(bytecode *bc, unsigned int *i, unsigned long val) { +void emit_word(bytecode *bc, unsigned int *i, sexp_uint_t val) { bytecode tmp; if ((*bc)->len < (*i)+4) { tmp = (bytecode) SEXP_ALLOC(sizeof(unsigned int) + (*bc)->len*2); @@ -147,7 +166,7 @@ void emit_word(bytecode *bc, unsigned int *i, unsigned long val) { *i += sizeof(unsigned long); } -#define emit_push(bc,i,obj) (emit(bc,i,OP_PUSH), emit_word(bc,i,(unsigned long)obj)) +#define emit_push(bc,i,obj) (emit(bc,i,OP_PUSH), emit_word(bc,i,(sexp_uint_t)obj)) sexp make_procedure(sexp bc, sexp vars) { sexp proc = SEXP_NEW(); @@ -167,26 +186,18 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, sexp o1, o2, cell; if (SEXP_PAIRP(obj)) { - /* fprintf(stderr, ":: pair\n"); */ if (SEXP_SYMBOLP(SEXP_CAR(obj))) { - fprintf(stderr, ":: symbol application\n"); o1 = env_cell(e, SEXP_CAR(obj)); - /* fprintf(stderr, ":: => %p\n", o1); */ if (! o1) errx(1, "unknown operator: %s", SEXP_CAR(obj)); o1 = SEXP_CDR(o1); - /* fprintf(stderr, ":: => %p\n", o1); */ if (SEXP_COREP(o1)) { - /* core form */ - fprintf(stderr, ":: core form\n"); switch (((core_form)o1)->code) { case CORE_LAMBDA: - fprintf(stderr, ":: lambda\n"); analyze_lambda(SEXP_FALSE, SEXP_CADR(obj), SEXP_CDDR(obj), bc, i, e, params, fv, sv, d); break; case CORE_DEFINE: - fprintf(stderr, "compiling global set: %p\n", SEXP_CADR(obj)); if ((((core_form)o1)->code == CORE_DEFINE) && SEXP_PAIRP(SEXP_CADR(obj))) { analyze_lambda(SEXP_CAR(SEXP_CADR(obj)), @@ -197,17 +208,13 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, analyze(SEXP_CADDR(obj), bc, i, e, params, fv, sv, d); } emit(bc, i, OP_GLOBAL_SET); - emit_word(bc, i, (unsigned long) (SEXP_PAIRP(SEXP_CADR(obj)) - ? SEXP_CAR(SEXP_CADR(obj)) - : SEXP_CADR(obj))); - emit(bc, i, OP_PUSH); + emit_word(bc, i, (sexp_uint_t) (SEXP_PAIRP(SEXP_CADR(obj)) + ? SEXP_CAR(SEXP_CADR(obj)) + : SEXP_CADR(obj))); + emit_push(bc, i, SEXP_UNDEF); (*d)++; - emit_word(bc, i, (unsigned long) SEXP_UNDEF); break; case CORE_SET: - fprintf(stderr, "set!: "); write_sexp(stderr, SEXP_CADR(obj)); - fprintf(stderr, " sv: "); write_sexp(stderr, sv); - fprintf(stderr, "\n"); analyze(SEXP_CADDR(obj), bc, i, e, params, fv, sv, d); analyze_var_ref(SEXP_CADR(obj), bc, i, e, params, fv, SEXP_NULL, d); emit(bc, i, OP_SET_CAR); @@ -219,38 +226,31 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, } break; case CORE_IF: - fprintf(stderr, "test clause: %d\n", *i); analyze(SEXP_CADR(obj), bc, i, e, params, fv, sv, d); emit(bc, i, OP_JUMP_UNLESS); /* jumps if test fails */ tmp1 = *i; emit(bc, i, 0); - fprintf(stderr, "pass clause: %d\n", *i); analyze(SEXP_CADDR(obj), bc, i, e, params, fv, sv, d); emit(bc, i, OP_JUMP); tmp2 = *i; emit(bc, i, 0); ((signed char*) (*bc)->data)[tmp1] = (*i)-tmp1-1; /* patch */ - fprintf(stderr, "fail clause: %d\n", *i); if (SEXP_PAIRP(SEXP_CDDDR(obj))) { analyze(SEXP_CADDDR(obj), bc, i, e, params, fv, sv, d); } else { - emit(bc, i, OP_PUSH); + emit_push(bc, i, SEXP_UNDEF); (*d)++; - emit_word(bc, i, (unsigned long) SEXP_UNDEF); } ((signed char*) (*bc)->data)[tmp2] = (*i)-tmp2-1; /* patch */ break; case CORE_QUOTE: - emit(bc, i, OP_PUSH); + emit_push(bc, i, SEXP_CADR(obj)); (*d)++; - emit_word(bc, i, (unsigned long)SEXP_CADR(obj)); break; default: errx(1, "unknown core form: %s", ((core_form)o1)->code); } } else if (SEXP_OPCODEP(o1)) { - fprintf(stderr, ":: opcode\n"); - /* direct opcode */ /* verify arity */ switch (((opcode)o1)->op_class) { case OPC_TYPE_PREDICATE: @@ -258,6 +258,9 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, case OPC_ARITHMETIC: case OPC_ARITHMETIC_INV: case OPC_ARITHMETIC_CMP: + case OPC_CONSTRUCTOR: + case OPC_ACCESSOR: + case OPC_GENERIC: if (SEXP_NULLP(SEXP_CDR(obj))) { errx(1, "unknown opcode class: %d", ((opcode)o1)->op_class); } else if (SEXP_NULLP(SEXP_CDDR(obj))) { @@ -268,12 +271,10 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, analyze(SEXP_CADR(obj), bc, i, e, params, fv, sv, d); } } else { - /* fprintf(stderr, ":: class: %d\n", ((opcode)o1)->op_class); */ for (o2 = reverse(SEXP_CDR(obj)); SEXP_PAIRP(o2); o2 = SEXP_CDR(o2)) { /* fprintf(stderr, ":: arg: %d\n", SEXP_CAR(o2)); */ analyze(SEXP_CAR(o2), bc, i, e, params, fv, sv, d); } - fprintf(stderr, ":: name: %d\n", ((opcode)o1)->op_name); emit(bc, i, ((opcode)o1)->op_name); (*d) -= length(SEXP_CDDR(obj)); } @@ -301,9 +302,7 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, } else if (SEXP_SYMBOLP(obj)) { analyze_var_ref(obj, bc, i, e, params, fv, sv, d); } else { - fprintf(stderr, "push: %d\n", (unsigned long)obj); - emit(bc, i, OP_PUSH); - emit_word(bc, i, (unsigned long)obj); + emit_push(bc, i, obj); (*d)++; } } @@ -311,27 +310,27 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, void analyze_var_ref (sexp obj, bytecode *bc, unsigned int *i, env e, sexp params, sexp fv, sexp sv, unsigned int *d) { int tmp; - fprintf(stderr, "symbol lookup, param length: %d sv: ", length(params)); - write_sexp(stderr, sv); - fprintf(stderr, "\n"); +/* fprintf(stderr, "symbol lookup, param length: %d sv: ", length(params)); */ +/* write_sexp(stderr, sv); */ +/* fprintf(stderr, "\n"); */ if ((tmp = list_index(params, obj)) >= 0) { - fprintf(stderr, "compiling local ref: %p => %d (d = %d)\n", obj, tmp, *d); + /* fprintf(stderr, "compiling local ref: %p => %d (d = %d)\n", obj, tmp, *d); */ emit(bc, i, OP_STACK_REF); emit_word(bc, i, tmp + *d + 4); (*d)++; } else if ((tmp = list_index(fv, obj)) >= 0) { - fprintf(stderr, "compiling closure ref: %p => %d\n", obj, tmp); + /* fprintf(stderr, "compiling closure ref: %p => %d\n", obj, tmp); */ emit(bc, i, OP_CLOSURE_REF); emit_word(bc, i, tmp); (*d)++; } else { - fprintf(stderr, "compiling global ref: %p\n", obj); + /* fprintf(stderr, "compiling global ref: %p\n", obj); */ emit(bc, i, OP_GLOBAL_REF); - emit_word(bc, i, (unsigned long) obj); + emit_word(bc, i, (sexp_uint_t) obj); (*d)++; } if (list_index(sv, obj) >= 0) { - fprintf(stderr, "mutable variables, fetching CAR\n"); + /* fprintf(stderr, "mutable variable, fetching CAR\n"); */ emit(bc, i, OP_CAR); } } @@ -351,7 +350,7 @@ void analyze_app (sexp obj, bytecode *bc, unsigned int *i, /* make the call */ emit(bc, i, OP_CALL); - emit_word(bc, i, (unsigned long) make_integer(len)); + emit_word(bc, i, (sexp_uint_t) make_integer(len)); } sexp free_vars (env e, sexp formals, sexp obj, sexp fv) { @@ -391,14 +390,11 @@ sexp set_vars (env e, sexp formals, sexp obj, sexp sv) { if (((core_form)SEXP_CDR(tmp))->code == CORE_LAMBDA) { formals = lset_diff(formals, SEXP_CADR(obj)); return set_vars(e, formals, SEXP_CADDR(obj), sv); - } else if (((core_form)SEXP_CDR(tmp))->code == CORE_SET) { - if ((list_index(formals, SEXP_CADR(obj)) >= 0) - && ! (list_index(sv, SEXP_CADR(obj)) >= 0)) { - fprintf(stderr, "found set! "); write_sexp(stderr, SEXP_CADR(obj)); - fprintf(stderr, "\n"); - sv = cons(SEXP_CADR(obj), sv); - return set_vars(e, formals, SEXP_CADDR(obj), sv); - } + } else if (((core_form)SEXP_CDR(tmp))->code == CORE_SET + && (list_index(formals, SEXP_CADR(obj)) >= 0) + && ! (list_index(sv, SEXP_CADR(obj)) >= 0)) { + sv = cons(SEXP_CADR(obj), sv); + return set_vars(e, formals, SEXP_CADDR(obj), sv); } } } @@ -420,24 +416,20 @@ void analyze_lambda (sexp name, sexp formals, sexp body, write_sexp(stderr, fv2); fprintf(stderr, "\n"); obj = (sexp) compile(formals, body, e2, fv2, sv, 0); - emit(bc, i, OP_PUSH); - emit_word(bc, i, (unsigned long) SEXP_UNDEF); - emit(bc, i, OP_PUSH); - emit_word(bc, i, (unsigned long) make_integer(length(fv2))); + emit_push(bc, i, SEXP_UNDEF); + emit_push(bc, i, make_integer(length(fv2))); emit(bc, i, OP_MAKE_VECTOR); (*d)++; for (ls=fv2, k=0; SEXP_PAIRP(ls); ls=SEXP_CDR(ls), k++) { analyze_var_ref(SEXP_CAR(ls), bc, i, e, params, fv, SEXP_NULL, d); - emit(bc, i, OP_PUSH); - emit_word(bc, i, (unsigned long) make_integer(k)); + emit_push(bc, i, make_integer(k)); emit(bc, i, OP_STACK_REF); emit_word(bc, i, 3); emit(bc, i, OP_VECTOR_SET); emit(bc, i, OP_DROP); (*d)--; } - emit(bc, i, OP_PUSH); - emit_word(bc, i, (unsigned long) obj); + emit_push(bc, i, obj); emit(bc, i, OP_MAKE_PROCEDURE); } @@ -445,15 +437,14 @@ bytecode compile(sexp params, sexp obj, env e, sexp fv, sexp sv, int done_p) { unsigned int i = 0, j, d = 0; bytecode bc = (bytecode) SEXP_ALLOC(sizeof(struct bytecode)+INIT_BCODE_SIZE); sexp sv2 = set_vars(e, params, obj, SEXP_NULL), ls; - fprintf(stderr, "set-vars: "); write_sexp(stderr, sv2); fprintf(stderr, "\n"); + /* fprintf(stderr, "set-vars: "); write_sexp(stderr, sv2); fprintf(stderr, "\n"); */ bc->tag = SEXP_BYTECODE; bc->len = INIT_BCODE_SIZE; - fprintf(stderr, "analyzing\n"); + /* fprintf(stderr, "analyzing\n"); */ for (ls=params; SEXP_PAIRP(ls); ls=SEXP_CDR(ls)) { if ((j = list_index(sv2, SEXP_CAR(ls)) >= 0)) { - fprintf(stderr, "consing mutable var\n"); - emit(&bc, &i, OP_PUSH); - emit_word(&bc, &i, (unsigned long) SEXP_NULL); + /* fprintf(stderr, "consing mutable var\n"); */ + emit_push(&bc, &i, SEXP_NULL); emit(&bc, &i, OP_STACK_REF); emit_word(&bc, &i, j+4); emit(&bc, &i, OP_CONS); @@ -464,13 +455,12 @@ bytecode compile(sexp params, sexp obj, env e, sexp fv, sexp sv, int done_p) { } sv = append(sv2, sv); for ( ; SEXP_PAIRP(obj); obj=SEXP_CDR(obj)) { - fprintf(stderr, "loop: "); write_sexp(stderr, obj); fprintf(stderr, "\n"); + /* fprintf(stderr, "loop: "); write_sexp(stderr, obj); fprintf(stderr, "\n"); */ analyze(SEXP_CAR(obj), &bc, &i, e, params, fv, sv, &d); if (SEXP_PAIRP(SEXP_CDR(obj))) emit(&bc, &i, OP_DROP); } emit(&bc, &i, done_p ? OP_DONE : OP_RET); shrink_bcode(&bc, i); - fprintf(stderr, "done compiling:\n"); print_bytecode(bc); disasm(bc); return bc; @@ -491,42 +481,42 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { fprintf(stderr, "noop\n"); break; case OP_GLOBAL_REF: - fprintf(stderr, "global ref: ip: %p => %p: ", ip, ((sexp*)ip)[0]); - fflush(stderr); - write_sexp(stderr, ((sexp*)ip)[0]); - fprintf(stderr, "\n"); +/* fprintf(stderr, "global ref: ip: %p => %p: ", ip, ((sexp*)ip)[0]); */ +/* fflush(stderr); */ +/* write_sexp(stderr, ((sexp*)ip)[0]); */ +/* fprintf(stderr, "\n"); */ tmp = env_cell(e, ((sexp*)ip)[0]); stack[top++]=SEXP_CDR(tmp); ip += sizeof(sexp); break; case OP_GLOBAL_SET: - fprintf(stderr, "global set: %p: ", ((sexp*)ip)[0]); - fflush(stderr); - write_sexp(stderr, ((sexp*)ip)[0]); - fprintf(stderr, "\n"); +/* fprintf(stderr, "global set: %p: ", ((sexp*)ip)[0]); */ +/* fflush(stderr); */ +/* write_sexp(stderr, ((sexp*)ip)[0]); */ +/* fprintf(stderr, "\n"); */ env_define(e, ((sexp*)ip)[0], stack[--top]); ip += sizeof(sexp); break; case OP_STACK_REF: - fprintf(stderr, "stack ref: ip=%p, %d - %d => ", - ip, top, (unsigned long) ((sexp*)ip)[0]); - fflush(stderr); - write_sexp(stderr, stack[top - (unsigned int) ((sexp*)ip)[0]]); - fprintf(stderr, "\n"); +/* fprintf(stderr, "stack ref: ip=%p, %d - %d => ", */ +/* ip, top, (sexp_uint_t) ((sexp*)ip)[0]); */ +/* fflush(stderr); */ +/* write_sexp(stderr, stack[top - (unsigned int) ((sexp*)ip)[0]]); */ +/* fprintf(stderr, "\n"); */ stack[top] = stack[top - (unsigned int) ((sexp*)ip)[0]]; ip += sizeof(sexp); top++; break; case OP_STACK_SET: - stack[top - (unsigned int) ((sexp*)ip)[0]] = stack[top-1]; + stack[top - (sexp_sint_t) ((sexp*)ip)[0]] = stack[top-1]; stack[top-1] = SEXP_UNDEF; ip += sizeof(sexp); break; case OP_CLOSURE_REF: - fprintf(stderr, "closure-ref %d => ", ((sexp*)ip)[0]); - fflush(stderr); - write_sexp(stderr, vector_ref(cp,((sexp*)ip)[0])); - fprintf(stderr, "\n"); +/* fprintf(stderr, "closure-ref %d => ", ((sexp*)ip)[0]); */ +/* fflush(stderr); */ +/* write_sexp(stderr, vector_ref(cp,((sexp*)ip)[0])); */ +/* fprintf(stderr, "\n"); */ stack[top++]=vector_ref(cp,((sexp*)ip)[0]); ip += sizeof(sexp); break; @@ -535,13 +525,19 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { top--; break; case OP_VECTOR_SET: - fprintf(stderr, "vector-set! %p %d => ", stack[top-1], unbox_integer(stack[top-2])); - write_sexp(stderr, stack[top-3]); - fprintf(stderr, "\n"); vector_set(stack[top-1], stack[top-2], stack[top-3]); stack[top-3]=SEXP_UNDEF; top-=2; break; + case OP_STRING_REF: + stack[top-2]=string_ref(stack[top-1], stack[top-2]); + top--; + break; + case OP_STRING_SET: + string_set(stack[top-1], stack[top-2], stack[top-3]); + stack[top-3]=SEXP_UNDEF; + top-=2; + break; case OP_MAKE_PROCEDURE: stack[top-2]=make_procedure(stack[top-1], stack[top-2]); top--; @@ -551,7 +547,6 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { top--; break; case OP_PUSH: - /* fprintf(stderr, " (push)\n"); */ stack[top++]=((sexp*)ip)[0]; ip += sizeof(sexp); break; @@ -567,6 +562,33 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { stack[top-2]=stack[top-1]; stack[top-1]=tmp; break; + case OP_PAIRP: + stack[top-1]=SEXP_PAIRP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; + break; + case OP_NULLP: + stack[top-1]=SEXP_NULLP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; + break; + case OP_CHARP: + stack[top-1]=SEXP_CHARP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; + break; + case OP_INTEGERP: + stack[top-1]=SEXP_INTEGERP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; + break; + case OP_SYMBOLP: + stack[top-1]=SEXP_SYMBOLP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; + break; + case OP_STRINGP: + stack[top-1]=SEXP_STRINGP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; + break; + case OP_VECTORP: + stack[top-1]=SEXP_VECTORP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; + break; + case OP_PROCEDUREP: + stack[top-1]=SEXP_PROCEDUREP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; + break; + case OP_EOFP: + stack[top-1]=(stack[top-1] == SEXP_EOF) ? SEXP_TRUE : SEXP_FALSE; + break; case OP_CAR: stack[top-1]=car(stack[top-1]); break; @@ -588,7 +610,6 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { top--; break; case OP_ADD: - fprintf(stderr, "OP_ADD %d %d\n", stack[top-1], stack[top-2]); stack[top-2]=sexp_add(stack[top-1],stack[top-2]); top--; break; @@ -612,9 +633,26 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { stack[top-2]=((stack[top-2] < stack[top-1]) ? SEXP_TRUE : SEXP_FALSE); top--; break; + case OP_LE: + stack[top-2]=((stack[top-2] <= stack[top-1]) ? SEXP_TRUE : SEXP_FALSE); + top--; + break; + case OP_GT: + stack[top-2]=((stack[top-2] > stack[top-1]) ? SEXP_TRUE : SEXP_FALSE); + top--; + break; + case OP_GE: + stack[top-2]=((stack[top-2] >= stack[top-1]) ? SEXP_TRUE : SEXP_FALSE); + top--; + break; + case OP_EQ: + case OP_EQN: + stack[top-2]=((stack[top-2] == stack[top-1]) ? SEXP_TRUE : SEXP_FALSE); + top--; + break; case OP_CALL: - fprintf(stderr, "CALL\n"); - i = (unsigned long) ((sexp*)ip)[0]; + /* fprintf(stderr, "CALL\n"); */ + i = (sexp_uint_t) ((sexp*)ip)[0]; tmp = stack[top-1]; if (! SEXP_PROCEDUREP(tmp)) errx(2, "non-procedure application: %p", tmp); @@ -623,15 +661,15 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { stack[top+1] = cp; top+=2; bc = procedure_code(tmp); - print_bytecode(bc); - disasm(bc); + /* print_bytecode(bc); */ + /* disasm(bc); */ ip = bc->data; cp = procedure_vars(tmp); fprintf(stderr, "... calling procedure at %p\ncp: ", ip); write_sexp(stderr, cp); fprintf(stderr, "\n"); - fprintf(stderr, "stack at %d\n", top); - print_stack(stack, top); + /* fprintf(stderr, "stack at %d\n", top); */ + /* print_stack(stack, top); */ break; case OP_JUMP_UNLESS: fprintf(stderr, "JUMP UNLESS, stack top is %d\n", stack[top-1]); @@ -652,7 +690,7 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { fflush(stderr); write_sexp(stderr, stack[top-1]); fprintf(stderr, "...\n"); - print_stack(stack, top); + /* print_stack(stack, top); */ /* top-1 */ /* stack: args ... n ip result */ cp = stack[top-2]; @@ -698,21 +736,38 @@ sexp eval(sexp obj, env e) { int main (int argc, char **argv) { sexp obj, res, *stack; env e; + int i, quit=0; sexp_init(); e = make_standard_env(); stack = (sexp*) SEXP_ALLOC(sizeof(sexp) * INIT_STACK_SIZE); + /* parse options */ + for (i=1; i < argc && argv[i][0] == '-'; i++) { + switch (argv[i][1]) { + case 'e': + quit=1; + break; + default: + errx(1, "unknown option: %s", argv[i]); + } + } + /* repl */ - fprintf(stdout, "> "); - fflush(stdout); - while ((obj = read_sexp(stdin)) != SEXP_EOF) { - write_sexp(stdout, obj); - fprintf(stdout, "\n => "); - res = eval_in_stack(obj, e, stack, 0); - write_sexp(stdout, res); - fprintf(stdout, "\n> "); + if (! quit) { + fprintf(stdout, "> "); fflush(stdout); + while ((obj = read_sexp(stdin)) != SEXP_EOF) { + /* write_sexp(stdout, obj); */ + res = eval_in_stack(obj, e, stack, 0); + if (res != SEXP_UNDEF) { + /* fprintf(stdout, "\n "); */ + write_sexp(stdout, res); + fprintf(stdout, "\n"); + } + fprintf(stdout, "> "); + fflush(stdout); + } } return 0; } diff --git a/eval.h b/eval.h index a1596c9d..df328ffc 100644 --- a/eval.h +++ b/eval.h @@ -66,42 +66,58 @@ enum opcode_classes { OPC_ARITHMETIC_INV, OPC_ARITHMETIC_CMP, OPC_CONSTRUCTOR, + OPC_ACCESSOR, }; enum opcode_names { - OP_NOOP, /* 0 */ - OP_STACK_REF, /* 1 */ - OP_STACK_SET, /* 2 */ - OP_GLOBAL_REF, /* 3 */ - OP_GLOBAL_SET, /* 4 */ - OP_CLOSURE_REF, /* 5 */ - OP_CLOSURE_SET, /* 6 */ - OP_VECTOR_REF, /* 7 */ - OP_VECTOR_SET, /* 8 */ + OP_NOOP, + OP_CALL, + OP_JUMP_UNLESS, + OP_JUMP, + OP_RET, + OP_DONE, + OP_STACK_REF, + OP_STACK_SET, + OP_GLOBAL_REF, + OP_GLOBAL_SET, + OP_CLOSURE_REF, + OP_VECTOR_REF, + OP_VECTOR_SET, + OP_STRING_REF, + OP_STRING_SET, OP_MAKE_PROCEDURE, OP_MAKE_VECTOR, OP_PUSH, - OP_DUP, /* C */ + OP_DUP, OP_DROP, OP_SWAP, + OP_PAIRP, + OP_NULLP, + OP_VECTORP, + OP_INTEGERP, + OP_SYMBOLP, + OP_STRINGP, + OP_CHARP, + OP_EOFP, + OP_PROCEDUREP, OP_CAR, - OP_CDR, /* 10 */ - OP_SET_CAR, /* 11 */ - OP_SET_CDR, /* 12 */ + OP_CDR, + OP_SET_CAR, + OP_SET_CDR, OP_CONS, - OP_ADD, /* 14 */ + OP_ADD, OP_SUB, - OP_MUL, /* 16 */ + OP_MUL, OP_DIV, - OP_MOD, /* 18 */ + OP_MOD, OP_NEG, - OP_INV, /* 1A */ + OP_INV, OP_LT, - OP_CALL, /* 1C */ - OP_JUMP_UNLESS, - OP_JUMP, /* 1E */ - OP_RET, - OP_DONE, + OP_LE, + OP_GT, + OP_GE, + OP_EQN, + OP_EQ, }; /**************************** prototypes ******************************/ diff --git a/sexp.c b/sexp.c index 8e4b5535..ff728452 100644 --- a/sexp.c +++ b/sexp.c @@ -23,11 +23,6 @@ static sexp the_quote_symbol; static sexp the_quasiquote_symbol; static sexp the_unquote_symbol; static sexp the_unquote_splicing_symbol; -static sexp the_lambda_symbol; -static sexp the_begin_symbol; -static sexp the_define_symbol; -static sexp the_set_x_symbol; -static sexp the_if_symbol; static char separators[] = { /* 1 2 3 4 5 6 7 8 9 a b c d e f */ @@ -37,13 +32,11 @@ static char separators[] = { 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_ */ - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* x6_ */ - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* x7_ */ }; static int is_separator(int c) { /* return (!((c-9)&(~3))) | (~(c^4)); */ - return 0tag = SEXP_FLONUM; + flonum_value(x) = f; + return x; +} + sexp make_string(char *str) { sexp s = SEXP_NEW(); if (! s) return SEXP_ERROR; @@ -233,7 +234,7 @@ int string_hash(char *str, int acc) { sexp intern(char *str) { struct huff_entry he; - unsigned long len, res=FNV_OFFSET_BASIS, space=3, newbits, i, d, cell; + sexp_uint_t len, res=FNV_OFFSET_BASIS, space=3, newbits, i, d, cell; char c, *mystr, *p=str; sexp sym, *newtable; @@ -245,7 +246,7 @@ sexp intern(char *str) { if ((space+newbits) > (sizeof(sexp)*8)) { goto normal_intern; } - res |= (((unsigned long) he.bits) << space); + res |= (((sexp_uint_t) he.bits) << space); space += newbits; } return (sexp) (res + SEXP_ISYMBOL_TAG); @@ -285,7 +286,7 @@ sexp intern(char *str) { sym->tag = SEXP_SYMBOL; sym->data1 = (void*) len; sym->data2 = (void*) mystr; - symbol_table[cell] = (sexp) (((unsigned long)sym) + 3); + symbol_table[cell] = (sexp) (((sexp_uint_t)sym) + 3); return symbol_table[cell]; } @@ -367,6 +368,9 @@ void write_sexp (FILE *out, sexp obj) { fprintf(out, ")"); } break; + case SEXP_FLONUM: + fprintf(out, "%g", flonum_value(obj)); + break; case SEXP_PROCEDURE: fprintf(out, "#"); break; @@ -396,8 +400,8 @@ void write_sexp (FILE *out, sexp obj) { } else if (SEXP_SYMBOLP(obj)) { #ifdef USE_HUFF_SYMS - if (((unsigned long)obj&7)==7) { - c = ((unsigned long)obj)>>3; + if (((sexp_uint_t)obj&7)==7) { + c = ((sexp_uint_t)obj)>>3; while (c) { #include "sexp-unhuff.c" putc(res, out); @@ -407,20 +411,20 @@ void write_sexp (FILE *out, sexp obj) { fprintf(out, "%s", symbol_data(obj)); } else { - switch ((unsigned long) obj) { - case (int) SEXP_NULL: + switch ((sexp_uint_t) obj) { + case (sexp_uint_t) SEXP_NULL: fprintf(out, "()"); break; - case (int) SEXP_TRUE: + case (sexp_uint_t) SEXP_TRUE: fprintf(out, "#t"); break; - case (int) SEXP_FALSE: + case (sexp_uint_t) SEXP_FALSE: fprintf(out, "#f"); break; - case (int) SEXP_EOF: + case (sexp_uint_t) SEXP_EOF: fprintf(out, "#"); break; - case (int) SEXP_UNDEF: + case (sexp_uint_t) SEXP_UNDEF: fprintf(out, "#"); break; default: @@ -488,10 +492,19 @@ char* read_symbol(FILE *in, int init) { return res; } -int read_number(FILE *in) { - int res = 0; - int negativep = 0; - char c; +sexp read_float_tail(FILE *in, long whole) { + double res = 0.0, scale=0.1; + int c; + for (c=fgetc(in); isdigit(c); c=fgetc(in), scale*=0.1) + res += ((c<='9') ? (c - '0') : ((toupper(c) - 'A') + 10))*scale; + ungetc(c, in); + return make_flonum(whole + res); +} + +sexp read_number(FILE *in, int base) { + sexp tmp; + long res = 0, negativep = 0; + int c; c = fgetc(in); if (c == '-') { @@ -500,12 +513,22 @@ int read_number(FILE *in) { res = c - '0'; } - for (c=fgetc(in); isdigit(c); c=fgetc(in)) { - res = res * 10 + (c - '0'); + for (c=fgetc(in); isxdigit(c); c=fgetc(in)) + res = res * base + ((c<='9') ? (c - '0') : ((toupper(c) - 'A') + 10)); + if (c=='.') { + if (base != 10) { + fprintf(stderr, "decimal found in non-base 10"); + return SEXP_ERROR; + } + tmp = read_float_tail(in, res); + if (negativep && SEXP_FLONUMP(tmp)) + flonum_value(tmp) = -1 * flonum_value(tmp); + return tmp; + } else { + ungetc(c, in); } - ungetc(c, in); - return negativep ? -res : res; + return make_integer(negativep ? -res : res); } sexp read_sexp_raw (FILE *in) { @@ -581,10 +604,18 @@ sexp read_sexp_raw (FILE *in) { break; case '#': switch (c1=fgetc(in)) { -/* case 'b': */ -/* case 'd': */ -/* case 'o': */ -/* case 'x': */ + case 'b': + res = read_number(in, 2); + break; + case 'o': + res = read_number(in, 8); + break; + case 'd': + res = read_number(in, 10); + break; + case 'x': + res = read_number(in, 16); + break; /* case 'e': */ /* case 'i': */ case 'f': @@ -623,8 +654,7 @@ sexp read_sexp_raw (FILE *in) { res = SEXP_RAWDOT; } else if (isdigit(c1)) { ungetc(c1,in ); - /* res = read_float_tail(in); */ - res = SEXP_ERROR; + res = read_float_tail(in, 0); } else { ungetc(c1, in); str = read_symbol(in, '.'); @@ -637,13 +667,12 @@ sexp read_sexp_raw (FILE *in) { break; case '+': case '-': - fprintf(stderr, "plus/minus: %c\n", c1); c2 = fgetc(in); if (c2 == '.' || isdigit(c2)) { ungetc(c2, in); - res = make_integer(read_number(in) * ((c1 == '-') ? -1 : 1)); + res = read_number(in, 10); + if (c1 == '-') res = sexp_mul(res, -1); } else { - fprintf(stderr, "... symbol: %c\n", c2); ungetc(c2, in); str = read_symbol(in, c1); res = intern(str); @@ -653,7 +682,7 @@ sexp read_sexp_raw (FILE *in) { case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': ungetc(c1, in); - res = make_integer(read_number(in)); + res = read_number(in, 10); break; default: str = read_symbol(in, c1); @@ -683,11 +712,6 @@ void sexp_init() { the_quasiquote_symbol = intern("quasiquote"); the_unquote_symbol = intern("unquote"); the_unquote_splicing_symbol = intern("unquote-splicing"); - the_lambda_symbol = intern("lambda"); - the_begin_symbol = intern("begin"); - the_define_symbol = intern("define"); - the_set_x_symbol = intern("set!"); - the_if_symbol = intern("if"); } } diff --git a/sexp.h b/sexp.h index e2b88fa4..174297f3 100644 --- a/sexp.h +++ b/sexp.h @@ -5,6 +5,7 @@ #ifndef SEXP_H #define SEXP_H +#include #include #include #include @@ -67,6 +68,8 @@ enum sexp_types { SEXP_SYMBOL, SEXP_STRING, SEXP_VECTOR, + SEXP_FLONUM, + SEXP_BIGNUM, /* the following are used only by the evaluator */ SEXP_PROCEDURE, SEXP_ENV, @@ -81,6 +84,9 @@ typedef struct sexp_struct { void *data2; } *sexp; +typedef unsigned long sexp_uint_t; +typedef long sexp_sint_t; + #define MAKE_IMMEDIATE(n) ((sexp) ((n<<4) + 14)) #define SEXP_NULL MAKE_IMMEDIATE(0) #define SEXP_FALSE MAKE_IMMEDIATE(1) @@ -92,16 +98,17 @@ typedef struct sexp_struct { #define SEXP_RAWDOT MAKE_IMMEDIATE(7) /* internal use */ #define SEXP_NULLP(x) ((x) == SEXP_NULL) -#define SEXP_POINTERP(x) (((unsigned long)(x) & SEXP_FIXNUM_MASK) == SEXP_POINTER_TAG) -#define SEXP_INTEGERP(x) (((unsigned long)(x) & SEXP_FIXNUM_MASK) == SEXP_FIXNUM_TAG) -#define SEXP_ISYMBOLP(x) (((unsigned long)(x) & SEXP_IMMEDIATE_MASK) == SEXP_ISYMBOL_TAG) -#define SEXP_CHARP(x) (((unsigned long)(x) & SEXP_EXTENDED_MASK) == SEXP_CHAR_TAG) +#define SEXP_POINTERP(x) (((sexp_uint_t)(x) & SEXP_FIXNUM_MASK) == SEXP_POINTER_TAG) +#define SEXP_INTEGERP(x) (((sexp_uint_t)(x) & SEXP_FIXNUM_MASK) == SEXP_FIXNUM_TAG) +#define SEXP_ISYMBOLP(x) (((sexp_uint_t)(x) & SEXP_IMMEDIATE_MASK) == SEXP_ISYMBOL_TAG) +#define SEXP_CHARP(x) (((sexp_uint_t)(x) & SEXP_EXTENDED_MASK) == SEXP_CHAR_TAG) #define SEXP_BOOLEANP(x) (((x) == SEXP_TRUE) || ((x) == SEXP_FALSE)) #define SEXP_PAIRP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_PAIR) #define SEXP_STRINGP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_STRING) #define SEXP_LSYMBOLP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_SYMBOL) #define SEXP_VECTORP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_VECTOR) +#define SEXP_FLONUMP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_FLONUM) #define SEXP_PROCEDUREP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_PROCEDURE) #define SEXP_ENVP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_ENV) #define SEXP_BYTECODEP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag ==SEXP_BYTECODE) @@ -111,7 +118,7 @@ typedef struct sexp_struct { #define SEXP_SYMBOLP(x) (SEXP_ISYMBOLP(x) || SEXP_LSYMBOLP(x)) #ifdef USE_HUFF_SYMS -#define SEXP_DOTP(x) (((unsigned long)(x))==((0x5D00<>SEXP_EXTENDED_BITS) -#define vector_length(x) ((unsigned long) x->data1) +#define flonum_value(f) (((double*)(((sexp_uint_t)f)+sizeof(char)))[0]) + +#define vector_length(x) ((sexp_uint_t) x->data1) #define vector_data(x) ((sexp*) x->data2) #define vector_ref(x, i) (vector_data(x)[unbox_integer(i)]) @@ -130,18 +139,21 @@ typedef struct sexp_struct { #define procedure_code(x) ((bytecode) ((sexp)x)->data1) #define procedure_vars(x) ((sexp) ((sexp)x)->data2) -#define string_length(x) ((unsigned long) x->data1) +#define string_length(x) ((sexp_uint_t) x->data1) #define string_data(x) ((char*) x->data2) -#define symbol_pointer(x) ((sexp) (((unsigned long)x)-SEXP_LSYMBOL_TAG)) -#define symbol_length(x) ((unsigned long) (symbol_pointer(x)->data1)) +#define string_ref(x, i) (make_character(string_data(x)[unbox_integer(i)])) +#define string_set(x, i, v) (string_data(x)[unbox_integer(i)] = unbox_character(v)) + +#define symbol_pointer(x) ((sexp) (((sexp_uint_t)x)-SEXP_LSYMBOL_TAG)) +#define symbol_length(x) ((sexp_uint_t) (symbol_pointer(x)->data1)) #define symbol_data(x) ((char*) (symbol_pointer(x)->data2)) -#define sexp_add(a, b) ((sexp)(((unsigned long)a)+((unsigned long)b)-SEXP_FIXNUM_TAG)) -#define sexp_sub(a, b) ((sexp)(((unsigned long)a)-((unsigned long)b)+SEXP_FIXNUM_TAG)) -#define sexp_mul(a, b) ((sexp)((((((unsigned long)a)-SEXP_FIXNUM_TAG)*(((unsigned long)b)>>SEXP_FIXNUM_BITS))+SEXP_FIXNUM_TAG))) -#define sexp_div(a, b) ((sexp)(((((unsigned long)a)>>SEXP_FIXNUM_BITS)/(((unsigned long)b)>>SEXP_FIXNUM_BITS))<>SEXP_FIXNUM_BITS)%(((unsigned long)b)>>SEXP_FIXNUM_BITS))<>SEXP_FIXNUM_BITS))+SEXP_FIXNUM_TAG))) +#define sexp_div(a, b) ((sexp)(((((sexp_sint_t)a)>>SEXP_FIXNUM_BITS)/(((sexp_sint_t)b)>>SEXP_FIXNUM_BITS))<>SEXP_FIXNUM_BITS)%(((sexp_sint_t)b)>>SEXP_FIXNUM_BITS))< Date: Wed, 4 Mar 2009 23:27:36 +0900 Subject: [PATCH 012/154] switching to ports instead of streams --- config.h | 1 + debug.c | 4 +- eval.c | 165 +++++++++++-------- eval.h | 2 + sexp.c | 491 ++++++++++++++++++++++++++++++------------------------- sexp.h | 143 ++++++++++------ 6 files changed, 464 insertions(+), 342 deletions(-) diff --git a/config.h b/config.h index bb962e65..1c739fae 100644 --- a/config.h +++ b/config.h @@ -5,4 +5,5 @@ #define USE_BOEHM 1 #define USE_HUFF_SYMS 1 #define USE_DEBUG 1 +#define USE_STRING_STREAMS 1 diff --git a/debug.c b/debug.c index dfab37f8..6ed46153 100644 --- a/debug.c +++ b/debug.c @@ -31,7 +31,7 @@ void disasm (bytecode bc) { case OP_GLOBAL_SET: case OP_CALL: case OP_PUSH: - write_sexp(stderr, ((sexp*)ip)[0]); + sexp_write(((sexp*)ip)[0], cur_error_port); ip += sizeof(sexp); break; case OP_JUMP: @@ -75,7 +75,7 @@ void print_stack (sexp *stack, int top) { for (i=0; iparent) { - if (assq(id, e->bindings) != SEXP_FALSE) + if (sexp_assq(id, e->bindings) != SEXP_FALSE) return 0; else e = e->parent; @@ -94,7 +114,7 @@ void env_define(env e, sexp key, sexp value) { if (cell) { SEXP_CDR(cell) = value; } else { - e->bindings = cons(cons(key, value), e->bindings); + e->bindings = sexp_cons(sexp_cons(key, value), e->bindings); } } @@ -105,7 +125,8 @@ env extend_env_closure (env e, sexp fv) { e2->parent = e; e2->bindings = SEXP_NULL; for (i=0; SEXP_PAIRP(fv); fv = SEXP_CDR(fv), i++) { - e2->bindings = cons(cons(SEXP_CAR(fv), make_integer(i)), e2->bindings); + e2->bindings = sexp_cons(sexp_cons(SEXP_CAR(fv), sexp_make_integer(i)), + e2->bindings); } return e2; } @@ -117,10 +138,10 @@ env make_standard_env() { e->parent = NULL; e->bindings = SEXP_NULL; for (i=0; i<(sizeof(core_forms)/sizeof(struct core_form)); i++) { - env_define(e, intern(core_forms[i].name), (sexp)(&core_forms[i])); + env_define(e, sexp_intern(core_forms[i].name), (sexp)(&core_forms[i])); } for (i=0; i<(sizeof(opcodes)/sizeof(struct opcode)); i++) { - env_define(e, intern(opcodes[i].name), (sexp)(&opcodes[i])); + env_define(e, sexp_intern(opcodes[i].name), (sexp)(&opcodes[i])); } return e; } @@ -168,7 +189,7 @@ void emit_word(bytecode *bc, unsigned int *i, sexp_uint_t val) { #define emit_push(bc,i,obj) (emit(bc,i,OP_PUSH), emit_word(bc,i,(sexp_uint_t)obj)) -sexp make_procedure(sexp bc, sexp vars) { +sexp sexp_make_procedure(sexp bc, sexp vars) { sexp proc = SEXP_NEW(); if (! proc) return SEXP_ERROR; proc->tag = SEXP_PROCEDURE; @@ -271,12 +292,13 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, analyze(SEXP_CADR(obj), bc, i, e, params, fv, sv, d); } } else { - for (o2 = reverse(SEXP_CDR(obj)); SEXP_PAIRP(o2); o2 = SEXP_CDR(o2)) { + for (o2 = sexp_reverse(SEXP_CDR(obj)); SEXP_PAIRP(o2); + o2 = SEXP_CDR(o2)) { /* fprintf(stderr, ":: arg: %d\n", SEXP_CAR(o2)); */ analyze(SEXP_CAR(o2), bc, i, e, params, fv, sv, d); } emit(bc, i, ((opcode)o1)->op_name); - (*d) -= length(SEXP_CDDR(obj)); + (*d) -= sexp_length(SEXP_CDDR(obj)); } break; default: @@ -311,14 +333,14 @@ void analyze_var_ref (sexp obj, bytecode *bc, unsigned int *i, env e, sexp params, sexp fv, sexp sv, unsigned int *d) { int tmp; /* fprintf(stderr, "symbol lookup, param length: %d sv: ", length(params)); */ -/* write_sexp(stderr, sv); */ +/* sexp_write(sv, stderr); */ /* fprintf(stderr, "\n"); */ - if ((tmp = list_index(params, obj)) >= 0) { + if ((tmp = sexp_list_index(params, obj)) >= 0) { /* fprintf(stderr, "compiling local ref: %p => %d (d = %d)\n", obj, tmp, *d); */ emit(bc, i, OP_STACK_REF); emit_word(bc, i, tmp + *d + 4); (*d)++; - } else if ((tmp = list_index(fv, obj)) >= 0) { + } else if ((tmp = sexp_list_index(fv, obj)) >= 0) { /* fprintf(stderr, "compiling closure ref: %p => %d\n", obj, tmp); */ emit(bc, i, OP_CLOSURE_REF); emit_word(bc, i, tmp); @@ -329,7 +351,7 @@ void analyze_var_ref (sexp obj, bytecode *bc, unsigned int *i, env e, emit_word(bc, i, (sexp_uint_t) obj); (*d)++; } - if (list_index(sv, obj) >= 0) { + if (sexp_list_index(sv, obj) >= 0) { /* fprintf(stderr, "mutable variable, fetching CAR\n"); */ emit(bc, i, OP_CAR); } @@ -338,10 +360,10 @@ void analyze_var_ref (sexp obj, bytecode *bc, unsigned int *i, env e, void analyze_app (sexp obj, bytecode *bc, unsigned int *i, env e, sexp params, sexp fv, sexp sv, unsigned int *d) { sexp o1; - unsigned long len = length(SEXP_CDR(obj)); + unsigned long len = sexp_length(SEXP_CDR(obj)); /* push the arguments onto the stack */ - for (o1 = reverse(SEXP_CDR(obj)); SEXP_PAIRP(o1); o1 = SEXP_CDR(o1)) { + for (o1 = sexp_reverse(SEXP_CDR(obj)); SEXP_PAIRP(o1); o1 = SEXP_CDR(o1)) { analyze(SEXP_CAR(o1), bc, i, e, params, fv, sv, d); } @@ -350,18 +372,18 @@ void analyze_app (sexp obj, bytecode *bc, unsigned int *i, /* make the call */ emit(bc, i, OP_CALL); - emit_word(bc, i, (sexp_uint_t) make_integer(len)); + emit_word(bc, i, (sexp_uint_t) sexp_make_integer(len)); } sexp free_vars (env e, sexp formals, sexp obj, sexp fv) { sexp o1; if (SEXP_SYMBOLP(obj)) { if (env_global_p(e, obj) - || (list_index(formals, obj) >= 0) - || (list_index(fv, obj) >= 0)) + || (sexp_list_index(formals, obj) >= 0) + || (sexp_list_index(fv, obj) >= 0)) return fv; else - return cons(obj, fv); + return sexp_cons(obj, fv); } else if (SEXP_PAIRP(obj)) { if (SEXP_SYMBOLP(SEXP_CAR(obj))) { if ((o1 = env_cell(e, SEXP_CAR(obj))) @@ -388,12 +410,12 @@ sexp set_vars (env e, sexp formals, sexp obj, sexp sv) { if (SEXP_SYMBOLP(SEXP_CAR(obj))) { if ((tmp = env_cell(e, SEXP_CAR(obj))) && SEXP_COREP(SEXP_CDR(tmp))) { if (((core_form)SEXP_CDR(tmp))->code == CORE_LAMBDA) { - formals = lset_diff(formals, SEXP_CADR(obj)); + formals = sexp_lset_diff(formals, SEXP_CADR(obj)); return set_vars(e, formals, SEXP_CADDR(obj), sv); } else if (((core_form)SEXP_CDR(tmp))->code == CORE_SET - && (list_index(formals, SEXP_CADR(obj)) >= 0) - && ! (list_index(sv, SEXP_CADR(obj)) >= 0)) { - sv = cons(SEXP_CADR(obj), sv); + && (sexp_list_index(formals, SEXP_CADR(obj)) >= 0) + && ! (sexp_list_index(sv, SEXP_CADR(obj)) >= 0)) { + sv = sexp_cons(SEXP_CADR(obj), sv); return set_vars(e, formals, SEXP_CADDR(obj), sv); } } @@ -412,17 +434,17 @@ void analyze_lambda (sexp name, sexp formals, sexp body, sexp obj, ls, fv2 = free_vars(e, formals, body, SEXP_NULL); env e2 = extend_env_closure(e, formals); int k; - fprintf(stderr, "%d free-vars\n", length(fv2)); - write_sexp(stderr, fv2); + fprintf(stderr, "%d free-vars\n", sexp_length(fv2)); + sexp_write(fv2, cur_error_port); fprintf(stderr, "\n"); obj = (sexp) compile(formals, body, e2, fv2, sv, 0); emit_push(bc, i, SEXP_UNDEF); - emit_push(bc, i, make_integer(length(fv2))); + emit_push(bc, i, sexp_make_integer(sexp_length(fv2))); emit(bc, i, OP_MAKE_VECTOR); (*d)++; for (ls=fv2, k=0; SEXP_PAIRP(ls); ls=SEXP_CDR(ls), k++) { analyze_var_ref(SEXP_CAR(ls), bc, i, e, params, fv, SEXP_NULL, d); - emit_push(bc, i, make_integer(k)); + emit_push(bc, i, sexp_make_integer(k)); emit(bc, i, OP_STACK_REF); emit_word(bc, i, 3); emit(bc, i, OP_VECTOR_SET); @@ -437,12 +459,12 @@ bytecode compile(sexp params, sexp obj, env e, sexp fv, sexp sv, int done_p) { unsigned int i = 0, j, d = 0; bytecode bc = (bytecode) SEXP_ALLOC(sizeof(struct bytecode)+INIT_BCODE_SIZE); sexp sv2 = set_vars(e, params, obj, SEXP_NULL), ls; - /* fprintf(stderr, "set-vars: "); write_sexp(stderr, sv2); fprintf(stderr, "\n"); */ + /* fprintf(stderr, "set-vars: "); sexp_write(sv2, stderr); fprintf(stderr, "\n"); */ bc->tag = SEXP_BYTECODE; bc->len = INIT_BCODE_SIZE; /* fprintf(stderr, "analyzing\n"); */ for (ls=params; SEXP_PAIRP(ls); ls=SEXP_CDR(ls)) { - if ((j = list_index(sv2, SEXP_CAR(ls)) >= 0)) { + if ((j = sexp_list_index(sv2, SEXP_CAR(ls)) >= 0)) { /* fprintf(stderr, "consing mutable var\n"); */ emit_push(&bc, &i, SEXP_NULL); emit(&bc, &i, OP_STACK_REF); @@ -453,9 +475,9 @@ bytecode compile(sexp params, sexp obj, env e, sexp fv, sexp sv, int done_p) { emit(&bc, &i, OP_DROP); } } - sv = append(sv2, sv); + sv = sexp_append(sv2, sv); for ( ; SEXP_PAIRP(obj); obj=SEXP_CDR(obj)) { - /* fprintf(stderr, "loop: "); write_sexp(stderr, obj); fprintf(stderr, "\n"); */ + /* fprintf(stderr, "loop: "); sexp_write(obj, stderr); fprintf(stderr, "\n"); */ analyze(SEXP_CAR(obj), &bc, &i, e, params, fv, sv, &d); if (SEXP_PAIRP(SEXP_CDR(obj))) emit(&bc, &i, OP_DROP); } @@ -483,7 +505,7 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { case OP_GLOBAL_REF: /* fprintf(stderr, "global ref: ip: %p => %p: ", ip, ((sexp*)ip)[0]); */ /* fflush(stderr); */ -/* write_sexp(stderr, ((sexp*)ip)[0]); */ +/* sexp_write(stderr, ((sexp*)ip)[0]); */ /* fprintf(stderr, "\n"); */ tmp = env_cell(e, ((sexp*)ip)[0]); stack[top++]=SEXP_CDR(tmp); @@ -492,7 +514,7 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { case OP_GLOBAL_SET: /* fprintf(stderr, "global set: %p: ", ((sexp*)ip)[0]); */ /* fflush(stderr); */ -/* write_sexp(stderr, ((sexp*)ip)[0]); */ +/* sexp_write(stderr, ((sexp*)ip)[0]); */ /* fprintf(stderr, "\n"); */ env_define(e, ((sexp*)ip)[0], stack[--top]); ip += sizeof(sexp); @@ -501,7 +523,7 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { /* fprintf(stderr, "stack ref: ip=%p, %d - %d => ", */ /* ip, top, (sexp_uint_t) ((sexp*)ip)[0]); */ /* fflush(stderr); */ -/* write_sexp(stderr, stack[top - (unsigned int) ((sexp*)ip)[0]]); */ +/* sexp_write(stderr, stack[top - (unsigned int) ((sexp*)ip)[0]]); */ /* fprintf(stderr, "\n"); */ stack[top] = stack[top - (unsigned int) ((sexp*)ip)[0]]; ip += sizeof(sexp); @@ -515,35 +537,35 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { case OP_CLOSURE_REF: /* fprintf(stderr, "closure-ref %d => ", ((sexp*)ip)[0]); */ /* fflush(stderr); */ -/* write_sexp(stderr, vector_ref(cp,((sexp*)ip)[0])); */ +/* sexp_write(stderr, vector_ref(cp,((sexp*)ip)[0])); */ /* fprintf(stderr, "\n"); */ - stack[top++]=vector_ref(cp,((sexp*)ip)[0]); + stack[top++]=sexp_vector_ref(cp,((sexp*)ip)[0]); ip += sizeof(sexp); break; case OP_VECTOR_REF: - stack[top-2]=vector_ref(stack[top-1], stack[top-2]); + stack[top-2]=sexp_vector_ref(stack[top-1], stack[top-2]); top--; break; case OP_VECTOR_SET: - vector_set(stack[top-1], stack[top-2], stack[top-3]); + sexp_vector_set(stack[top-1], stack[top-2], stack[top-3]); stack[top-3]=SEXP_UNDEF; top-=2; break; case OP_STRING_REF: - stack[top-2]=string_ref(stack[top-1], stack[top-2]); + stack[top-2]=sexp_string_ref(stack[top-1], stack[top-2]); top--; break; case OP_STRING_SET: - string_set(stack[top-1], stack[top-2], stack[top-3]); + sexp_string_set(stack[top-1], stack[top-2], stack[top-3]); stack[top-3]=SEXP_UNDEF; top-=2; break; case OP_MAKE_PROCEDURE: - stack[top-2]=make_procedure(stack[top-1], stack[top-2]); + stack[top-2]=sexp_make_procedure(stack[top-1], stack[top-2]); top--; break; case OP_MAKE_VECTOR: - stack[top-2]=make_vector(unbox_integer(stack[top-1]), stack[top-2]); + stack[top-2]=sexp_make_vector(sexp_unbox_integer(stack[top-1]), stack[top-2]); top--; break; case OP_PUSH: @@ -590,23 +612,23 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { stack[top-1]=(stack[top-1] == SEXP_EOF) ? SEXP_TRUE : SEXP_FALSE; break; case OP_CAR: - stack[top-1]=car(stack[top-1]); + stack[top-1]=sexp_car(stack[top-1]); break; case OP_CDR: - stack[top-1]=cdr(stack[top-1]); + stack[top-1]=sexp_cdr(stack[top-1]); break; case OP_SET_CAR: - set_car(stack[top-1], stack[top-2]); + sexp_set_car(stack[top-1], stack[top-2]); stack[top-2]=SEXP_UNDEF; top--; break; case OP_SET_CDR: - set_cdr(stack[top-1], stack[top-2]); + sexp_set_cdr(stack[top-1], stack[top-2]); stack[top-2]=SEXP_UNDEF; top--; break; case OP_CONS: - stack[top-2]=cons(stack[top-1], stack[top-2]); + stack[top-2]=sexp_cons(stack[top-1], stack[top-2]); top--; break; case OP_ADD: @@ -657,16 +679,16 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { if (! SEXP_PROCEDUREP(tmp)) errx(2, "non-procedure application: %p", tmp); stack[top-1] = (sexp) i; - stack[top] = make_integer(ip+4); + stack[top] = sexp_make_integer(ip+4); stack[top+1] = cp; top+=2; - bc = procedure_code(tmp); + bc = sexp_procedure_code(tmp); /* print_bytecode(bc); */ /* disasm(bc); */ ip = bc->data; - cp = procedure_vars(tmp); + cp = sexp_procedure_vars(tmp); fprintf(stderr, "... calling procedure at %p\ncp: ", ip); - write_sexp(stderr, cp); + /* sexp_write(cp, stderr); */ fprintf(stderr, "\n"); /* fprintf(stderr, "stack at %d\n", top); */ /* print_stack(stack, top); */ @@ -688,14 +710,14 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { case OP_RET: fprintf(stderr, "returning @ %d: ", top-1); fflush(stderr); - write_sexp(stderr, stack[top-1]); + sexp_write(stack[top-1], cur_error_port); fprintf(stderr, "...\n"); /* print_stack(stack, top); */ /* top-1 */ /* stack: args ... n ip result */ cp = stack[top-2]; - ip = (unsigned char*) unbox_integer(stack[top-3]); - i = unbox_integer(stack[top-4]); + ip = (unsigned char*) sexp_unbox_integer(stack[top-3]); + i = sexp_unbox_integer(stack[top-4]); stack[top-i-4] = stack[top-1]; top = top-i-3; fprintf(stderr, "... done returning\n"); @@ -703,7 +725,7 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { case OP_DONE: fprintf(stderr, "finally returning @ %d: ", top-1); fflush(stderr); - write_sexp(stderr, stack[top-1]); + sexp_write(stack[top-1], cur_error_port); fprintf(stderr, "\n"); goto end_loop; default: @@ -722,7 +744,7 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { sexp eval_in_stack(sexp obj, env e, sexp* stack, unsigned int top) { bytecode bc; - bc = compile(SEXP_NULL, cons(obj, SEXP_NULL), e, SEXP_NULL, SEXP_NULL, 1); + bc = compile(SEXP_NULL, sexp_cons(obj, SEXP_NULL), e, SEXP_NULL, SEXP_NULL, 1); return vm(bc, e, stack, top); } @@ -733,12 +755,22 @@ sexp eval(sexp obj, env e) { return res; } +void scheme_init() { + if (! scheme_initialized_p) { + scheme_initialized_p = 1; + sexp_init(); + cur_input_port = sexp_make_input_port(stdin); + cur_output_port = sexp_make_output_port(stdout); + cur_error_port = sexp_make_output_port(stderr); + } +} + int main (int argc, char **argv) { - sexp obj, res, *stack; + sexp obj, res, in, out, *stack; env e; int i, quit=0; - sexp_init(); + scheme_init(); e = make_standard_env(); stack = (sexp*) SEXP_ALLOC(sizeof(sexp) * INIT_STACK_SIZE); @@ -754,19 +786,18 @@ int main (int argc, char **argv) { } /* repl */ - if (! quit) { + while (! quit) { fprintf(stdout, "> "); fflush(stdout); - while ((obj = read_sexp(stdin)) != SEXP_EOF) { - /* write_sexp(stdout, obj); */ + obj = sexp_read(cur_input_port); + if (obj == SEXP_EOF) { + quit = 1; + } else { res = eval_in_stack(obj, e, stack, 0); if (res != SEXP_UNDEF) { - /* fprintf(stdout, "\n "); */ - write_sexp(stdout, res); - fprintf(stdout, "\n"); + sexp_write(res, cur_output_port); + sexp_write_char('\n', cur_output_port); } - fprintf(stdout, "> "); - fflush(stdout); } } return 0; diff --git a/eval.h b/eval.h index df328ffc..29b758c0 100644 --- a/eval.h +++ b/eval.h @@ -12,6 +12,8 @@ #define INIT_BCODE_SIZE 128 #define INIT_STACK_SIZE 1024 +#define sexp_debug(msg, obj) (sexp_write_string(msg,cur_error_port), sexp_write(obj, cur_error_port), sexp_write_char('\n',cur_error_port)) + typedef struct bytecode { char tag; unsigned int len; diff --git a/sexp.c b/sexp.c index ff728452..16c060c5 100644 --- a/sexp.c +++ b/sexp.c @@ -1,6 +1,6 @@ -/* sexp.c -- sexp library implementation */ +/* sexp.c -- standalone sexp library implementation */ /* Copyright (c) 2009 Alex Shinn. All rights reserved. */ -/* BSD-style license: http://synthcode.com/license.txt */ +/* BSD-style license: http://synthcode.com/license.txt */ #include "sexp.h" @@ -16,7 +16,7 @@ static struct huff_entry huff_table[] = { }; #endif -static int initialized_p = 0; +static int sexp_initialized_p = 0; static sexp the_dot_symbol; static sexp the_quote_symbol; @@ -24,7 +24,7 @@ static sexp the_quasiquote_symbol; static sexp the_unquote_symbol; static sexp the_unquote_splicing_symbol; -static char separators[] = { +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_ */ @@ -36,7 +36,7 @@ static char separators[] = { static int is_separator(int c) { /* return (!((c-9)&(~3))) | (~(c^4)); */ - return 0tag) { case SEXP_PAIR: - free_sexp(car(obj)); - free_sexp(cdr(obj)); + sexp_free(SEXP_CAR(obj)); + sexp_free(SEXP_CDR(obj)); break; case SEXP_VECTOR: - len = vector_length(obj); - elts = vector_data(obj); + len = sexp_vector_length(obj); + elts = sexp_vector_data(obj); for (i=0; itag = SEXP_PAIR; @@ -84,37 +84,21 @@ sexp cons(sexp head, sexp tail) { return pair; } -sexp car(sexp obj) { +sexp sexp_car(sexp obj) { return (SEXP_PAIRP(obj)) ? SEXP_CAR(obj) : SEXP_ERROR; } -sexp cdr(sexp obj) { +sexp sexp_cdr(sexp obj) { return (SEXP_PAIRP(obj)) ? SEXP_CDR(obj) : SEXP_ERROR; } -sexp set_car(sexp obj, sexp val) { - if (SEXP_PAIRP(obj)) - return SEXP_CAR(obj) = val; - else { - sexp_debug("error: set-car! not a pair: ", obj); - return SEXP_ERROR; - } -} - -sexp set_cdr(sexp obj, sexp val) { - if (SEXP_PAIRP(obj)) - return SEXP_CDR(obj) = val; - else - return SEXP_ERROR; -} - -int listp (sexp obj) { +int sexp_listp (sexp obj) { while (SEXP_PAIRP(obj)) obj = SEXP_CDR(obj); return (obj == SEXP_NULL); } -int list_index (sexp ls, sexp elt) { +int sexp_list_index (sexp ls, sexp elt) { int i=0; while (SEXP_PAIRP(ls)) { if (SEXP_CAR(ls) == elt) @@ -125,7 +109,7 @@ int list_index (sexp ls, sexp elt) { return -1; } -sexp memq (sexp x, sexp ls) { +sexp sexp_memq (sexp x, sexp ls) { while (SEXP_PAIRP(ls)) if (x == SEXP_CAR(ls)) return ls; @@ -134,7 +118,7 @@ sexp memq (sexp x, sexp ls) { return SEXP_FALSE; } -sexp assq (sexp x, sexp ls) { +sexp sexp_assq (sexp x, sexp ls) { while (SEXP_PAIRP(ls)) if (x == SEXP_CAAR(ls)) return ls; @@ -143,22 +127,22 @@ sexp assq (sexp x, sexp ls) { return SEXP_FALSE; } -sexp lset_diff(sexp a, sexp b) { +sexp sexp_lset_diff(sexp a, sexp b) { sexp res = SEXP_NULL; for ( ; SEXP_PAIRP(a); a=SEXP_CDR(a)) - if (! list_index(b, SEXP_CAR(a)) >= 0) - res = cons(SEXP_CAR(a), res); + if (! sexp_list_index(b, SEXP_CAR(a)) >= 0) + res = sexp_cons(SEXP_CAR(a), res); return res; } -sexp reverse(sexp ls) { +sexp sexp_reverse(sexp ls) { sexp res = SEXP_NULL; for ( ; SEXP_PAIRP(ls); ls=SEXP_CDR(ls)) - res = cons(SEXP_CAR(ls), res); + res = sexp_cons(SEXP_CAR(ls), res); return res; } -sexp nreverse(sexp ls) { +sexp sexp_nreverse(sexp ls) { sexp a, b, tmp; if (ls == SEXP_NULL) { return ls; @@ -166,52 +150,52 @@ sexp nreverse(sexp ls) { return SEXP_ERROR; } else { b=ls; - a=cdr(ls); - set_cdr(b, SEXP_NULL); + a=SEXP_CDR(ls); + SEXP_CDR(b) = SEXP_NULL; for ( ; SEXP_PAIRP(a); b=a, a=tmp) { - tmp=cdr(a); - set_cdr(a, b); + tmp=SEXP_CDR(a); + SEXP_CDR(a) = b; } return b; } } -sexp append(sexp a, sexp b) { - for (a=reverse(a); SEXP_PAIRP(a); a=SEXP_CDR(a)) - b = cons(SEXP_CAR(a), 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 list(int count, ...) { +sexp sexp_list(int count, ...) { sexp res = SEXP_NULL; int i; va_list ap; va_start(ap, count); for (i=0; itag = SEXP_FLONUM; - flonum_value(x) = f; + sexp_flonum_value(x) = f; return x; } -sexp make_string(char *str) { +sexp sexp_make_string(char *str) { sexp s = SEXP_NEW(); if (! s) return SEXP_ERROR; unsigned long len = strlen(str); @@ -227,12 +211,12 @@ sexp make_string(char *str) { #define FNV_PRIME 16777619 #define FNV_OFFSET_BASIS 2166136261uL -int string_hash(char *str, int acc) { +int sexp_string_hash(char *str, int acc) { while (*str) {acc *= FNV_PRIME; acc ^= *str++;} return acc; } -sexp intern(char *str) { +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; @@ -253,15 +237,15 @@ sexp intern(char *str) { #endif normal_intern: - res = string_hash(p, res); + res = sexp_string_hash(p, res); d = symbol_table_primes[symbol_table_prime_index]; cell = res % d; for (i=0; i= 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_free((sexp)vec); +} + +sexp sexp_make_input_port(FILE* in) { + sexp p = SEXP_NEW(); + if (p == NULL) return SEXP_ERROR; + p->tag = SEXP_IPORT; + p->data1 = in; + return p; +} + +sexp sexp_make_output_port(FILE* out) { + sexp p = SEXP_NEW(); + if (p == NULL) return SEXP_ERROR; + p->tag = SEXP_OPORT; + p->data1 = out; + return p; +} + +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 + +void sexp_write (sexp obj, sexp out) { unsigned long len, i, c, res; sexp x, *elts; + char *str; if (! obj) { - fprintf(out, "#"); + sexp_write_string("#", out); } else if (SEXP_POINTERP(obj)) { switch (obj->tag) { case SEXP_PAIR: - fprintf(out, "("); - write_sexp(out, car(obj)); - for (x=cdr(obj); SEXP_PAIRP(x); x=cdr(x)) { - fprintf(out, " "); - write_sexp(out, car(x)); + 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)) { - fprintf(out, " . "); - write_sexp(out, x); + sexp_write_string(" . ", out); + sexp_write(x, out); } - fprintf(out, ")"); + sexp_write_char(')', out); break; case SEXP_VECTOR: - len = vector_length(obj); - elts = vector_data(obj); + len = sexp_vector_length(obj); + elts = sexp_vector_data(obj); if (len == 0) { - fprintf(out, "#()"); + sexp_write_string("#()", out); } else { - fprintf(out, "#("); - write_sexp(out, elts[0]); + sexp_write_string("#(", out); + sexp_write(out, elts[0]); for (i=1; i"); - break; + sexp_write_string("#", out); break; + case SEXP_IPORT: + sexp_write_string("#", out); break; + case SEXP_OPORT: + sexp_write_string("#", out); break; case SEXP_BYTECODE: - fprintf(out, "#"); - break; + sexp_write_string("#", out); break; case SEXP_ENV: - fprintf(out, "#"); - break; + sexp_write_string("#", out); break; case SEXP_STRING: - fprintf(out, "\""); + sexp_write_char('"', out); + i = sexp_string_length(obj); + str = sexp_string_data(obj); /* FALLTHROUGH */ case SEXP_SYMBOL: - fprintf(out, "%s", string_data(obj)); + if (obj->tag != SEXP_STRING) { + 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 (obj->tag == SEXP_STRING) - fprintf(out, "\""); + sexp_write_char('"', out); break; } } else if (SEXP_INTEGERP(obj)) { - fprintf(out, "%d", unbox_integer(obj)); + sexp_printf(out, "%d", sexp_unbox_integer(obj)); } else if (SEXP_CHARP(obj)) { - if (33 <= unbox_character(obj) < 127) { - fprintf(out, "#\\%c", unbox_character(obj)); + if (33 <= sexp_unbox_character(obj) < 127) { + sexp_printf(out, "#\\%c", sexp_unbox_character(obj)); } else { - fprintf(out, "#\\x%02d", unbox_character(obj)); + sexp_printf(out, "#\\x%02d", sexp_unbox_character(obj)); } } else if (SEXP_SYMBOLP(obj)) { @@ -404,51 +463,45 @@ void write_sexp (FILE *out, sexp obj) { c = ((sexp_uint_t)obj)>>3; while (c) { #include "sexp-unhuff.c" - putc(res, out); + sexp_write_char(res, out); } - } else + } #endif - fprintf(out, "%s", symbol_data(obj)); } else { switch ((sexp_uint_t) obj) { case (sexp_uint_t) SEXP_NULL: - fprintf(out, "()"); - break; + sexp_write_string("()", out); break; case (sexp_uint_t) SEXP_TRUE: - fprintf(out, "#t"); - break; + sexp_write_string("#t", out); break; case (sexp_uint_t) SEXP_FALSE: - fprintf(out, "#f"); - break; + sexp_write_string("#f", out); break; case (sexp_uint_t) SEXP_EOF: - fprintf(out, "#"); - break; + sexp_write_string("#", out); break; case (sexp_uint_t) SEXP_UNDEF: - fprintf(out, "#"); - break; + sexp_write_string("#", out); break; default: - fprintf(out, "#"); + sexp_write_string("#", out); } } } -char* read_string(FILE *in) { +char* sexp_read_string(sexp in) { char *buf, *tmp, *res; - char c; - int len; + int c, len, size=128; - buf = SEXP_ALLOC(128); + buf = SEXP_ALLOC(size); /* XXXX grow! */ tmp = buf; - for (c=fgetc(in); (c != EOF) && (c != '"'); c=fgetc(in)) { - if (c == '\\') { - c=fgetc(in); + 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'; - case 't': - c = '\t'; + case 'n': c = '\n'; break; + case 't': c = '\t'; break; } *tmp++ = c; } else { @@ -464,21 +517,20 @@ char* read_string(FILE *in) { return res; } -char* read_symbol(FILE *in, int init) { +char* sexp_read_symbol(sexp in, int init) { char *buf, *tmp, *res; - char c; - int len; + int c, len, size=128; - buf = SEXP_ALLOC(128); + buf = SEXP_ALLOC(size); tmp = buf; if (init != EOF) *tmp++ = init; while (1) { - c=fgetc(in); + c=sexp_read_char(in); if (c == EOF || is_separator(c)) { - ungetc(c, in); + sexp_push_char(c, in); break; } *tmp++ = c; @@ -492,57 +544,56 @@ char* read_symbol(FILE *in, int init) { return res; } -sexp read_float_tail(FILE *in, long whole) { +sexp sexp_read_float_tail(sexp in, long whole) { double res = 0.0, scale=0.1; int c; - for (c=fgetc(in); isdigit(c); c=fgetc(in), scale*=0.1) + for (c=sexp_read_char(in); isdigit(c); c=sexp_read_char(in), scale*=0.1) res += ((c<='9') ? (c - '0') : ((toupper(c) - 'A') + 10))*scale; - ungetc(c, in); - return make_flonum(whole + res); + sexp_push_char(c, in); + return sexp_make_flonum(whole + res); } -sexp read_number(FILE *in, int base) { +sexp sexp_read_number(sexp in, int base) { sexp tmp; - long res = 0, negativep = 0; - int c; + long res = 0, negativep = 0, c; - c = fgetc(in); + c = sexp_read_char(in); if (c == '-') { negativep = 1; } else if (isdigit(c)) { res = c - '0'; } - for (c=fgetc(in); isxdigit(c); c=fgetc(in)) + for (c=sexp_read_char(in); isxdigit(c); c=sexp_read_char(in)) res = res * base + ((c<='9') ? (c - '0') : ((toupper(c) - 'A') + 10)); if (c=='.') { if (base != 10) { fprintf(stderr, "decimal found in non-base 10"); return SEXP_ERROR; } - tmp = read_float_tail(in, res); + tmp = sexp_read_float_tail(in, res); if (negativep && SEXP_FLONUMP(tmp)) - flonum_value(tmp) = -1 * flonum_value(tmp); + sexp_flonum_value(tmp) = -1 * sexp_flonum_value(tmp); return tmp; } else { - ungetc(c, in); + sexp_push_char(c, in); } - return make_integer(negativep ? -res : res); + return sexp_make_integer(negativep ? -res : res); } -sexp read_sexp_raw (FILE *in) { +sexp sexp_read_raw (sexp in) { sexp res, tmp, tmp2; char *str; int c1, c2; scan_loop: - switch (c1 = fgetc(in)) { + switch (c1 = sexp_read_char(in)) { case EOF: res = SEXP_EOF; break; case ';': - while ((c1 = fgetc(in)) != EOF) + while ((c1 = sexp_read_char(in)) != EOF) if (c1 == '\n') break; /* fallthrough */ @@ -550,96 +601,98 @@ sexp read_sexp_raw (FILE *in) { case '\t': case '\n': goto scan_loop; - break; case '\'': - res = read_sexp(in); - res = list2(the_quote_symbol, res); + res = sexp_read(in); + res = sexp_list2(the_quote_symbol, res); break; case '`': - res = read_sexp(in); - res = list2(the_quasiquote_symbol, res); + res = sexp_read(in); + res = sexp_list2(the_quasiquote_symbol, res); break; case ',': - if ((c1 = fgetc(in)) == '@') { - res = read_sexp(in); - res = list2(the_unquote_splicing_symbol, res); + if ((c1 = sexp_read_char(in)) == '@') { + res = sexp_read(in); + res = sexp_list2(the_unquote_splicing_symbol, res); } else { - ungetc(c1, in); - res = read_sexp(in); - res = list2(the_unquote_symbol, res); + sexp_push_char(c1, in); + res = sexp_read(in); + res = sexp_list2(the_unquote_symbol, res); } break; case '"': - str = read_string(in); - res = make_string(str); + str = sexp_read_string(in); + res = sexp_make_string(str); SEXP_FREE(str); break; case '(': res = SEXP_NULL; - tmp = read_sexp_raw(in); + tmp = sexp_read_raw(in); while ((tmp != SEXP_ERROR) && (tmp != SEXP_EOF) && (tmp != SEXP_CLOSE)) { if (tmp == SEXP_RAWDOT) { - /* dotted list */ - free_sexp(tmp); - tmp = read_sexp_raw(in); - if (read_sexp(in) != SEXP_CLOSE) { - fprintf(stderr, "sexp: multiple tokens in dotted tail\n"); - res = SEXP_ERROR; + if (res == SEXP_NULL) { + fprintf(stderr, "sexp: dot before any elements in list\n"); + return SEXP_ERROR; } else { - tmp2 = res; - res = nreverse(res); - set_cdr(tmp2, tmp); - return res; + tmp = sexp_read_raw(in); + if (sexp_read(in) != SEXP_CLOSE) { + fprintf(stderr, "sexp: multiple tokens in dotted tail\n"); + sexp_free(res); + return SEXP_ERROR; + } else { + tmp2 = res; + res = sexp_nreverse(res); + SEXP_CDR(tmp2) = tmp; + return res; + } } } else { - res = cons(tmp, res); - tmp = read_sexp_raw(in); + res = sexp_cons(tmp, res); + tmp = sexp_read_raw(in); } } if (tmp != SEXP_CLOSE) { - free_sexp(res); + sexp_free(res); res = SEXP_ERROR; } - res = nreverse(res); + res = sexp_nreverse(res); break; case '#': - switch (c1=fgetc(in)) { + switch (c1=sexp_read_char(in)) { case 'b': - res = read_number(in, 2); - break; + res = sexp_read_number(in, 2); break; case 'o': - res = read_number(in, 8); - break; + res = sexp_read_number(in, 8); break; case 'd': - res = read_number(in, 10); - break; + res = sexp_read_number(in, 10); break; case 'x': - res = read_number(in, 16); - break; + res = sexp_read_number(in, 16); break; /* case 'e': */ /* case 'i': */ case 'f': case 't': - c2 = fgetc(in); + c2 = sexp_read_char(in); if (c2 == EOF || is_separator(c2)) { res = (c1 == 't' ? SEXP_TRUE : SEXP_FALSE); } else { fprintf(stderr, "sexp: invalid syntax #%c%c\n", c1, c2); res = SEXP_ERROR; } - ungetc(c2, in); + sexp_push_char(c2, in); break; + case ';': + sexp_read_raw(in); + goto scan_loop; case '(': - ungetc(c1, in); - res = read_sexp(in); - if (! listp(res)) { + sexp_push_char(c1, in); + res = sexp_read(in); + if (! sexp_listp(res)) { if (res != SEXP_ERROR) { fprintf(stderr, "sexp: dotted list not allowed in vector syntax\n"); - free_sexp(res); + sexp_free(res); res = SEXP_ERROR; } } else { - res = list_to_vector(res); + res = sexp_list_to_vector(res); } break; default: @@ -649,16 +702,16 @@ sexp read_sexp_raw (FILE *in) { } break; case '.': - c1 = fgetc(in); + c1 = sexp_read_char(in); if (c1 == EOF || is_separator(c1)) { res = SEXP_RAWDOT; } else if (isdigit(c1)) { - ungetc(c1,in ); - res = read_float_tail(in, 0); + sexp_push_char(c1,in ); + res = sexp_read_float_tail(in, 0); } else { - ungetc(c1, in); - str = read_symbol(in, '.'); - res = intern(str); + sexp_push_char(c1, in); + str = sexp_read_symbol(in, '.'); + res = sexp_intern(str); SEXP_FREE(str); } break; @@ -667,51 +720,51 @@ sexp read_sexp_raw (FILE *in) { break; case '+': case '-': - c2 = fgetc(in); + c2 = sexp_read_char(in); if (c2 == '.' || isdigit(c2)) { - ungetc(c2, in); - res = read_number(in, 10); + sexp_push_char(c2, in); + res = sexp_read_number(in, 10); if (c1 == '-') res = sexp_mul(res, -1); } else { - ungetc(c2, in); - str = read_symbol(in, c1); - res = intern(str); + 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': - ungetc(c1, in); - res = read_number(in, 10); + sexp_push_char(c1, in); + res = sexp_read_number(in, 10); break; default: - str = read_symbol(in, c1); - res = intern(str); + str = sexp_read_symbol(in, c1); + res = sexp_intern(str); SEXP_FREE(str); break; } return res; } -sexp read_sexp (FILE *in) { - sexp res = read_sexp_raw(in); +sexp sexp_read (sexp in) { + sexp res = sexp_read_raw(in); if ((res == SEXP_CLOSE) || (res == SEXP_RAWDOT)) res = SEXP_ERROR; return res; } void sexp_init() { - if (! initialized_p) { - initialized_p = 1; + if (! sexp_initialized_p) { + sexp_initialized_p = 1; #ifdef USE_BOEHM GC_init(); #endif symbol_table = SEXP_ALLOC(symbol_table_primes[0]*sizeof(sexp)); - the_dot_symbol = intern("."); - the_quote_symbol = intern("quote"); - the_quasiquote_symbol = intern("quasiquote"); - the_unquote_symbol = intern("unquote"); - the_unquote_splicing_symbol = intern("unquote-splicing"); + 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"); } } diff --git a/sexp.h b/sexp.h index 174297f3..729110fb 100644 --- a/sexp.h +++ b/sexp.h @@ -1,6 +1,6 @@ -/* sexp.h -- header for sexp library */ +/* sexp.h -- header for sexp library */ /* Copyright (c) 2009 Alex Shinn. All rights reserved. */ -/* BSD-style license: http://synthcode.com/license.txt */ +/* BSD-style license: http://synthcode.com/license.txt */ #ifndef SEXP_H #define SEXP_H @@ -20,7 +20,9 @@ #define errx(code, msg, ...) (fprintf(stderr,msg"\n",__VA_ARGS__), exit(code)) #endif -#define sexp_debug(msg, obj) (fprintf(stderr,msg), fflush(stderr), write_sexp(stderr, obj), fprintf(stderr,"\n")) +#if defined(__APPLE__) || defined(__FreeBSD__) || defined(__NetBSD__) || defined(__DragonFly__) || defined(__OpenBSD__) +#define SEXP_BSD +#endif #ifdef USE_BOEHM #include "gc/include/gc.h" @@ -70,6 +72,8 @@ enum sexp_types { SEXP_VECTOR, SEXP_FLONUM, SEXP_BIGNUM, + SEXP_IPORT, + SEXP_OPORT, /* the following are used only by the evaluator */ SEXP_PROCEDURE, SEXP_ENV, @@ -109,6 +113,8 @@ typedef long sexp_sint_t; #define SEXP_LSYMBOLP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_SYMBOL) #define SEXP_VECTORP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_VECTOR) #define SEXP_FLONUMP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_FLONUM) +#define SEXP_IPORTP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_IPORT) +#define SEXP_OPORTP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_OPORT) #define SEXP_PROCEDUREP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_PROCEDURE) #define SEXP_ENVP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_ENV) #define SEXP_BYTECODEP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag ==SEXP_BYTECODE) @@ -120,34 +126,57 @@ typedef long sexp_sint_t; #ifdef USE_HUFF_SYMS #define SEXP_DOTP(x) (((sexp_uint_t)(x))==((0x5D00<>SEXP_FIXNUM_BITS) -#define make_character(n) ((sexp) (((long) n<>SEXP_EXTENDED_BITS) +#define sexp_make_integer(n) ((sexp) (((long) n<>SEXP_FIXNUM_BITS) +#define sexp_make_character(n) ((sexp) (((long) n<>SEXP_EXTENDED_BITS) -#define flonum_value(f) (((double*)(((sexp_uint_t)f)+sizeof(char)))[0]) +#define sexp_flonum_value(f) (((double*)(((sexp_uint_t)f)+sizeof(char)))[0]) -#define vector_length(x) ((sexp_uint_t) x->data1) -#define vector_data(x) ((sexp*) x->data2) +#define sexp_vector_length(x) ((sexp_uint_t) x->data1) +#define sexp_vector_data(x) ((sexp*) (((sexp)x)->data2)) -#define vector_ref(x, i) (vector_data(x)[unbox_integer(i)]) -#define vector_set(x, i, v) (vector_data(x)[unbox_integer(i)] = (v)) +#define sexp_vector_ref(x, i) (sexp_vector_data(x)[sexp_unbox_integer(i)]) +#define sexp_vector_set(x, i, v) (sexp_vector_data(x)[sexp_unbox_integer(i)] = (v)) -#define procedure_code(x) ((bytecode) ((sexp)x)->data1) -#define procedure_vars(x) ((sexp) ((sexp)x)->data2) +#define sexp_procedure_code(x) ((bytecode) ((sexp)x)->data1) +#define sexp_procedure_vars(x) ((sexp) ((sexp)x)->data2) -#define string_length(x) ((sexp_uint_t) x->data1) -#define string_data(x) ((char*) x->data2) +#define sexp_string_length(x) ((sexp_uint_t) x->data1) +#define sexp_string_data(x) ((char*) x->data2) -#define string_ref(x, i) (make_character(string_data(x)[unbox_integer(i)])) -#define string_set(x, i, v) (string_data(x)[unbox_integer(i)] = unbox_character(v)) +#define sexp_string_ref(x, i) (sexp_make_character(sexp_string_data(x)[sexp_unbox_integer(i)])) +#define sexp_string_set(x, i, v) (sexp_string_data(x)[sexp_unbox_integer(i)] = sexp_unbox_character(v)) -#define symbol_pointer(x) ((sexp) (((sexp_uint_t)x)-SEXP_LSYMBOL_TAG)) -#define symbol_length(x) ((sexp_uint_t) (symbol_pointer(x)->data1)) -#define symbol_data(x) ((char*) (symbol_pointer(x)->data2)) +#define sexp_port_stream(p) ((FILE*) ((sexp)p)->data1) + +#ifdef USE_STRING_STREAMS +#ifdef SEXP_BSD +#define fmemopen(str, len, m) funopen(sexp_vector(3, (sexp)str, (sexp)len, (sexp)0), sstream_read, sstream_write, sstream_seek, sstream_close) +int sstream_read(void *vec, char *dst, int n); +int sstream_write(void *vec, const char *src, int n); +off_t sstream_seek(void *vec, off_t offset, int whence); +int sstream_close(void *vec); +#endif +#define sexp_read_char(p) (getc(sexp_port_stream(p))) +#define sexp_push_char(c, p) (ungetc(c, sexp_port_stream(p))) +#define sexp_write_char(c, p) (putc(c, sexp_port_stream(p))) +#define sexp_write_string(s, p) (fputs(s, sexp_port_stream(p))) +#define sexp_printf(p, s, ...) (fprintf(sexp_port_stream(p), s, __VA_ARGS__)) +#else +sexp sexp_read_char(sexp port); +void sexp_push_char(sexp ch, sexp port); +void sexp_write_char(sexp ch, sexp port); +void sexp_write_string(sexp str, sexp port); +void sexp_printf(sexp port, sexp fmt, ...); +#endif + +#define sexp_symbol_pointer(x) ((sexp) (((sexp_uint_t)x)-SEXP_LSYMBOL_TAG)) +#define sexp_symbol_length(x) ((sexp_uint_t) (sexp_symbol_pointer(x)->data1)) +#define sexp_symbol_data(x) ((char*) (sexp_symbol_pointer(x)->data2)) #define sexp_add(a, b) ((sexp)(((sexp_sint_t)a)+((sexp_sint_t)b)-SEXP_FIXNUM_TAG)) #define sexp_sub(a, b) ((sexp)(((sexp_sint_t)a)-((sexp_sint_t)b)+SEXP_FIXNUM_TAG)) @@ -155,9 +184,10 @@ typedef long sexp_sint_t; #define sexp_div(a, b) ((sexp)(((((sexp_sint_t)a)>>SEXP_FIXNUM_BITS)/(((sexp_sint_t)b)>>SEXP_FIXNUM_BITS))<>SEXP_FIXNUM_BITS)%(((sexp_sint_t)b)>>SEXP_FIXNUM_BITS))<data1) #define SEXP_CDR(x) (((sexp)x)->data2) @@ -172,36 +202,41 @@ typedef long sexp_sint_t; #define SEXP_CADDDR(x) (SEXP_CADR(SEXP_CDDR(x))) #define SEXP_CDDDDR(x) (SEXP_CDDR(SEXP_CDDR(x))) -sexp cons(sexp head, sexp tail); -sexp car(sexp obj); -sexp cdr(sexp obj); -sexp set_car(sexp obj, sexp val); -sexp set_cdr(sexp obj, sexp val); +sexp sexp_cons(sexp head, sexp tail); +sexp sexp_car(sexp obj); +sexp sexp_cdr(sexp obj); +sexp sexp_set_car(sexp obj, sexp val); +sexp sexp_set_cdr(sexp obj, sexp val); -int listp(sexp obj); -int list_index(sexp ls, sexp elt); -sexp lset_diff(sexp a, sexp b); -sexp reverse(sexp ls); -sexp nreverse(sexp ls); -sexp append(sexp a, sexp b); -sexp list(int count, ...); -sexp memq(sexp x, sexp ls); -sexp assq (sexp x, sexp ls); -unsigned long length(sexp ls); -sexp make_string(char *str); -sexp make_flonum(double f); -int string_hash(char *str, int acc); -sexp intern(char *str); -sexp make_vector(unsigned long len, sexp dflt); -sexp list_to_vector(sexp ls); -sexp vector(int count, ...); -void write_sexp(FILE *out, sexp obj); -void free_sexp(sexp obj); -char* read_string(FILE *in); -char* read_symbol(FILE *in, int init); -sexp read_number(FILE *in, int base); -sexp read_sexp_raw(FILE *in); -sexp read_sexp(FILE *in); +int sexp_listp(sexp obj); +int sexp_list_index(sexp ls, sexp elt); +sexp sexp_lset_diff(sexp a, sexp b); +sexp sexp_reverse(sexp ls); +sexp sexp_nreverse(sexp ls); +sexp sexp_append(sexp a, sexp b); +sexp sexp_list(int count, ...); +sexp sexp_memq(sexp x, sexp ls); +sexp sexp_assq(sexp x, sexp ls); +unsigned long sexp_length(sexp ls); +sexp sexp_make_string(char *str); +sexp sexp_make_flonum(double f); +int sexp_string_hash(char *str, int acc); +sexp sexp_intern(char *str); +sexp sexp_make_vector(unsigned long len, sexp dflt); +sexp sexp_list_to_vector(sexp ls); +sexp sexp_vector(int count, ...); +void sexp_write(sexp obj, sexp out); +void sexp_free(sexp obj); +char* sexp_read_string(sexp in); +char* sexp_read_symbol(sexp in, int init); +sexp sexp_read_number(sexp in, int base); +sexp sexp_read_raw(sexp in); +sexp sexp_read(sexp in); +sexp sexp_make_input_port(FILE* in); +sexp sexp_make_output_port(FILE* out); +sexp sexp_make_input_string_port(sexp str); +sexp sexp_make_output_string_port(); +sexp sexp_get_output_string(sexp port); void sexp_init(); #endif /* ! SEXP_H */ From fde01c57004d1eafd78b953ec4e497128accd284 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 5 Mar 2009 01:24:16 +0900 Subject: [PATCH 013/154] adding sexp_read_from_string and -e, -p command-line options --- eval.c | 8 ++++++++ sexp.c | 9 +++++++++ sexp.h | 1 + 3 files changed, 18 insertions(+) diff --git a/eval.c b/eval.c index 00845b28..4588a1a4 100644 --- a/eval.c +++ b/eval.c @@ -778,7 +778,15 @@ int main (int argc, char **argv) { for (i=1; i < argc && argv[i][0] == '-'; i++) { switch (argv[i][1]) { case 'e': + case 'p': + obj = sexp_read_from_string(argv[i+1]); + res = eval_in_stack(obj, e, stack, 0); + if (argv[i][1] == 'p') { + sexp_write(res, cur_output_port); + sexp_write_char('\n', cur_output_port); + } quit=1; + i++; break; default: errx(1, "unknown option: %s", argv[i]); diff --git a/sexp.c b/sexp.c index 16c060c5..eb180664 100644 --- a/sexp.c +++ b/sexp.c @@ -753,6 +753,15 @@ sexp sexp_read (sexp 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_free(s); + sexp_free(in); + return res; +} + void sexp_init() { if (! sexp_initialized_p) { sexp_initialized_p = 1; diff --git a/sexp.h b/sexp.h index 729110fb..fed7ae22 100644 --- a/sexp.h +++ b/sexp.h @@ -232,6 +232,7 @@ char* sexp_read_symbol(sexp in, int init); sexp sexp_read_number(sexp in, int base); sexp sexp_read_raw(sexp in); sexp sexp_read(sexp in); +sexp sexp_read_from_string(char *str); sexp sexp_make_input_port(FILE* in); sexp sexp_make_output_port(FILE* out); sexp sexp_make_input_string_port(sexp str); From 1dd2afa68500ba35d9a1490e72f15b8126c00c52 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 5 Mar 2009 23:55:37 +0900 Subject: [PATCH 014/154] initial ffi support --- Makefile | 9 ++- debug.c | 15 ++-- eval.c | 241 ++++++++++++++++++++++++++++++++----------------------- eval.h | 32 ++++++-- sexp.c | 12 +-- sexp.h | 5 +- 6 files changed, 191 insertions(+), 123 deletions(-) diff --git a/Makefile b/Makefile index 65bd0c22..5cd571f0 100644 --- a/Makefile +++ b/Makefile @@ -10,13 +10,16 @@ GC_OBJ=./gc/gc.a $GC_OBJ: ./gc/alloc.c cd gc && make test -sexp.o: sexp.c sexp.h config.h +sexp.o: sexp.c sexp.h config.h Makefile gcc -c $(CFLAGS) -o $@ $< -eval.o: eval.c debug.c eval.h sexp.h config.h +eval.o: eval.c debug.c eval.h sexp.h config.h Makefile gcc -c $(CFLAGS) -o $@ $< -chibi-scheme: sexp.o eval.o $(GC_OBJ) +# main.o: main.c eval.h sexp.h config.h Makefile +# gcc -c $(CFLAGS) -o $@ $< + +chibi-scheme: eval.o sexp.o $(GC_OBJ) gcc $(CFLAGS) -o $@ $^ clean: diff --git a/debug.c b/debug.c index 6ed46153..3237b21f 100644 --- a/debug.c +++ b/debug.c @@ -3,13 +3,14 @@ /* BSD-style license: http://synthcode.com/license.txt */ static const char* reverse_opcode_names[] = - {"NOOP", "CALL", "JUMP_UNLESS", "JUMP", "RET", "DONE", "STACK_REF", - "STACK_SET", "GLOBAL_REF", "GLOBAL_SET", "CLOSURE_REF", "VECTOR_REF", - "VECTOR_SET", "STRING_REF", "STRING_SET", "MAKE_PROCEDURE", "MAKE_VECTOR", - "PUSH", "DUP", "DROP", "SWAP", "PAIRP", "NULLP", "VECTORP", "INTEGERP", - "SYMBOLP", "STRINGP", "CHARP", "EOFP", "PROCEDUREP", "CAR", "CDR", - "SET_CAR", "SET_CDR", "CONS", "ADD", "SUB", "MUL", "DIV", "MOD", "NEG", - "INV", "LT", "LE", "GT", "GE", "EQN", "EQ"}; + {"NOOP", "CALL", "FCALL0", "FCALL1", "FCALL2", "FCALL3", "FCALL4", "FCALL5", + "FCALL6", "FCALL7", "FCALLN", "JUMP_UNLESS", "JUMP", "RET", "DONE", + "STACK_REF", "STACK_SET", "GLOBAL_REF", "GLOBAL_SET", "CLOSURE_REF", + "VECTOR_REF", "VECTOR_SET", "STRING_REF", "STRING_SET", "MAKE_PROCEDURE", + "MAKE_VECTOR", "PUSH", "DUP", "DROP", "SWAP", "PAIRP", "NULLP", "VECTORP", + "INTEGERP", "SYMBOLP", "STRINGP", "CHARP", "EOFP", "PROCEDUREP", "IPORTP", + "OPORTP", "CAR", "CDR", "SET_CAR", "SET_CDR", "CONS", "ADD", "SUB", "MUL", + "DIV", "MOD", "NEG", "INV", "LT", "LE", "GT", "GE", "EQN", "EQ",}; void disasm (bytecode bc) { unsigned char *ip=bc->data, opcode; diff --git a/eval.c b/eval.c index 4588a1a4..5ffd34b5 100644 --- a/eval.c +++ b/eval.c @@ -9,53 +9,7 @@ static int scheme_initialized_p = 0; static sexp cur_input_port, cur_output_port, cur_error_port; - -static struct core_form core_forms[] = { - {SEXP_CORE, "define", CORE_DEFINE}, - {SEXP_CORE, "set!", CORE_SET}, - {SEXP_CORE, "lambda", CORE_LAMBDA}, - {SEXP_CORE, "if", CORE_IF}, - {SEXP_CORE, "begin", CORE_BEGIN}, - {SEXP_CORE, "quote", CORE_QUOTE}, - {SEXP_CORE, "define-syntax", CORE_DEFINE_SYNTAX}, - {SEXP_CORE, "let-syntax", CORE_LET_SYNTAX}, - {SEXP_CORE, "letrec-syntax", CORE_LETREC_SYNTAX}, -}; - -static struct opcode opcodes[] = { -#define _OP(c,o,n,m,t,u,s,i) {SEXP_OPCODE, c, o, n, m, t, u, s, i, NULL} -_OP(OPC_ACCESSOR, OP_CAR, 1, 0, SEXP_PAIR, 0, "car",0), -_OP(OPC_ACCESSOR, OP_SET_CAR, 2, 0, SEXP_PAIR, 0, "set-car!",0), -_OP(OPC_ACCESSOR, OP_CDR, 1, 0, SEXP_PAIR, 0, "cdr",0), -_OP(OPC_ACCESSOR, OP_SET_CDR, 2, 0, SEXP_PAIR, 0, "set-cdr!",0), -_OP(OPC_ACCESSOR, OP_VECTOR_REF,2,0, SEXP_VECTOR, SEXP_FIXNUM, "vector-ref",0), -_OP(OPC_ACCESSOR, OP_VECTOR_SET,3,0, SEXP_VECTOR, SEXP_FIXNUM, "vector-set!",0), -_OP(OPC_ACCESSOR, OP_STRING_REF,2,0, SEXP_STRING, SEXP_FIXNUM, "string-ref",0), -_OP(OPC_ACCESSOR, OP_STRING_SET,3,0, SEXP_STRING, SEXP_FIXNUM, "string-set!",0), -_OP(OPC_ARITHMETIC, OP_ADD, 0, 1, SEXP_FIXNUM, 0, "+", 0), -_OP(OPC_ARITHMETIC_INV, OP_SUB, 0, 1, SEXP_FIXNUM, 0, "-", OP_NEG), -_OP(OPC_ARITHMETIC, OP_MUL, 0, 1, SEXP_FIXNUM, 0, "*", 0), -_OP(OPC_ARITHMETIC_INV, OP_DIV, 0, 1, SEXP_FIXNUM, 0, "/", OP_INV), -_OP(OPC_ARITHMETIC, OP_MOD, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, "%", 0), -_OP(OPC_ARITHMETIC_CMP, OP_LT, 0, 1, SEXP_FIXNUM, 0, "<", 0), -_OP(OPC_ARITHMETIC_CMP, OP_LE, 0, 1, SEXP_FIXNUM, 0, "<=", 0), -_OP(OPC_ARITHMETIC_CMP, OP_GT, 0, 1, SEXP_FIXNUM, 0, ">", 0), -_OP(OPC_ARITHMETIC_CMP, OP_GE, 0, 1, SEXP_FIXNUM, 0, ">=", 0), -_OP(OPC_ARITHMETIC_CMP, OP_EQN, 0, 1, SEXP_FIXNUM, 0, "=", 0), -_OP(OPC_PREDICATE, OP_EQ, 2, 0, 0, 0, "eq?", 0), -_OP(OPC_CONSTRUCTOR, OP_CONS, 2, 0, 0, 0, "cons", 0), -_OP(OPC_CONSTRUCTOR, OP_MAKE_VECTOR, 2, 0, SEXP_FIXNUM, 0, "make-vector", 0), -_OP(OPC_CONSTRUCTOR, OP_MAKE_PROCEDURE, 2, 0, 0, 0, "make-procedure", 0), -_OP(OPC_TYPE_PREDICATE, OP_PAIRP, 1, 0, 0, 0, "pair?", 0), -_OP(OPC_TYPE_PREDICATE, OP_NULLP, 1, 0, 0, 0, "null?", 0), -_OP(OPC_TYPE_PREDICATE, OP_STRINGP, 1, 0, 0, 0, "string?", 0), -_OP(OPC_TYPE_PREDICATE, OP_SYMBOLP, 1, 0, 0, 0, "symbol?", 0), -_OP(OPC_TYPE_PREDICATE, OP_CHARP, 1, 0, 0, 0, "char?", 0), -_OP(OPC_TYPE_PREDICATE, OP_VECTORP, 1, 0, 0, 0, "vector?", 0), -_OP(OPC_TYPE_PREDICATE, OP_PROCEDUREP, 1, 0, 0, 0, "procedure?", 0), -_OP(OPC_TYPE_PREDICATE, OP_EOFP, 1, 0, 0, 0, "eof-object?", 0), -#undef _OP -}; +static sexp exception_handler; #ifdef USE_DEBUG #include "debug.c" @@ -131,21 +85,6 @@ env extend_env_closure (env e, sexp fv) { return e2; } -env make_standard_env() { - int i; - env e = (env) SEXP_ALLOC(sizeof(struct env)); - e->tag = SEXP_ENV; - e->parent = NULL; - e->bindings = SEXP_NULL; - for (i=0; i<(sizeof(core_forms)/sizeof(struct core_form)); i++) { - env_define(e, sexp_intern(core_forms[i].name), (sexp)(&core_forms[i])); - } - for (i=0; i<(sizeof(opcodes)/sizeof(struct opcode)); i++) { - env_define(e, sexp_intern(opcodes[i].name), (sexp)(&opcodes[i])); - } - return e; -} - /************************* bytecode utilities ***************************/ void shrink_bcode(bytecode *bc, unsigned int i) { @@ -290,6 +229,10 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, emit(bc, i, ((opcode)o1)->op_inverse); } else { analyze(SEXP_CADR(obj), bc, i, e, params, fv, sv, d); + if (((opcode)o1)->op_class != OPC_ARITHMETIC) { + emit(bc, i, ((opcode)o1)->op_name); + (*d)--; + } } } else { for (o2 = sexp_reverse(SEXP_CDR(obj)); SEXP_PAIRP(o2); @@ -301,11 +244,20 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, (*d) -= sexp_length(SEXP_CDDR(obj)); } break; + case OPC_FOREIGN: + for (o2 = sexp_reverse(SEXP_CDR(obj)); SEXP_PAIRP(o2); + o2 = SEXP_CDR(o2)) { + analyze(SEXP_CAR(o2), bc, i, e, params, fv, sv, d); + } + emit_push(bc, i, ((opcode)o1)->data); + emit(bc, i, ((opcode)o1)->op_name); + (*d) -= sexp_length(SEXP_CDR(obj)); + break; default: errx(1, "unknown opcode class: %d", ((opcode)o1)->op_class); } } else { - /* function call */ + /* general procedure call */ analyze_app(obj, bc, i, e, params, fv, sv, d); } } else if (SEXP_PAIRP(SEXP_CAR(obj))) { @@ -585,38 +537,31 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { stack[top-1]=tmp; break; case OP_PAIRP: - stack[top-1]=SEXP_PAIRP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; - break; + stack[top-1]=SEXP_PAIRP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break; case OP_NULLP: - stack[top-1]=SEXP_NULLP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; - break; + stack[top-1]=SEXP_NULLP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break; case OP_CHARP: - stack[top-1]=SEXP_CHARP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; - break; + stack[top-1]=SEXP_CHARP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break; case OP_INTEGERP: - stack[top-1]=SEXP_INTEGERP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; - break; + stack[top-1]=SEXP_INTEGERP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break; case OP_SYMBOLP: - stack[top-1]=SEXP_SYMBOLP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; - break; + stack[top-1]=SEXP_SYMBOLP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break; case OP_STRINGP: - stack[top-1]=SEXP_STRINGP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; - break; + stack[top-1]=SEXP_STRINGP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break; case OP_VECTORP: - stack[top-1]=SEXP_VECTORP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; - break; + stack[top-1]=SEXP_VECTORP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break; case OP_PROCEDUREP: - stack[top-1]=SEXP_PROCEDUREP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; - break; + stack[top-1]=SEXP_PROCEDUREP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break; + case OP_IPORTP: + stack[top-1]=SEXP_IPORTP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break; + case OP_OPORTP: + stack[top-1]=SEXP_OPORTP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break; case OP_EOFP: - stack[top-1]=(stack[top-1] == SEXP_EOF) ? SEXP_TRUE : SEXP_FALSE; - break; + stack[top-1]=(stack[top-1] == SEXP_EOF) ? SEXP_TRUE : SEXP_FALSE; break; case OP_CAR: - stack[top-1]=sexp_car(stack[top-1]); - break; + stack[top-1]=sexp_car(stack[top-1]); break; case OP_CDR: - stack[top-1]=sexp_cdr(stack[top-1]); - break; + stack[top-1]=sexp_cdr(stack[top-1]); break; case OP_SET_CAR: sexp_set_car(stack[top-1], stack[top-2]); stack[top-2]=SEXP_UNDEF; @@ -693,6 +638,21 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { /* fprintf(stderr, "stack at %d\n", top); */ /* print_stack(stack, top); */ break; + case OP_FCALL0: + stack[top-1]=((sexp_proc0)stack[top-1])(); + break; + case OP_FCALL1: + stack[top-2]=((sexp_proc1)stack[top-1])(stack[top-2]); + top--; + break; + case OP_FCALL2: + stack[top-3]=((sexp_proc2)stack[top-1])(stack[top-2],stack[top-3]); + top-=2; + break; + case OP_FCALL3: + stack[top-4]=((sexp_proc3)stack[top-1])(stack[top-2],stack[top-3],stack[top-4]); + top-=3; + break; case OP_JUMP_UNLESS: fprintf(stderr, "JUMP UNLESS, stack top is %d\n", stack[top-1]); if (stack[--top] == SEXP_FALSE) { @@ -742,6 +702,85 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { /************************** eval interface ****************************/ +static const struct core_form core_forms[] = { + {SEXP_CORE, CORE_DEFINE, "define"}, + {SEXP_CORE, CORE_SET, "set!"}, + {SEXP_CORE, CORE_LAMBDA, "lambda"}, + {SEXP_CORE, CORE_IF, "if"}, + {SEXP_CORE, CORE_BEGIN, "begin"}, + {SEXP_CORE, CORE_QUOTE, "quote"}, + {SEXP_CORE, CORE_DEFINE_SYNTAX, "define-syntax"}, + {SEXP_CORE, CORE_LET_SYNTAX, "let-syntax"}, + {SEXP_CORE, CORE_LETREC_SYNTAX, "letrec-syntax"}, +}; + +static const struct opcode opcodes[] = { +#define _OP(c,o,n,m,t,u,i,s) {SEXP_OPCODE, c, o, n, m, t, u, i, s, NULL, NULL} +#define _FN(o,n,t,u,s,f) {SEXP_OPCODE, OPC_FOREIGN, o, n, 0, t,u, 0, s, (sexp)f, NULL} +#define _FN0(s, f) _FN(OP_FCALL0, 0, 0, 0, s, f) +#define _FN1(t, s, f) _FN(OP_FCALL1, 1, t, 0, s, f) +#define _FN2(t, u, s, f) _FN(OP_FCALL2, 2, t, u, s, f) +_OP(OPC_ACCESSOR, OP_CAR, 1, 0, SEXP_PAIR, 0, 0, "car"), +_OP(OPC_ACCESSOR, OP_SET_CAR, 2, 0, SEXP_PAIR, 0, 0, "set-car!"), +_OP(OPC_ACCESSOR, OP_CDR, 1, 0, SEXP_PAIR, 0, 0, "cdr"), +_OP(OPC_ACCESSOR, OP_SET_CDR, 2, 0, SEXP_PAIR, 0, 0, "set-cdr!"), +_OP(OPC_ACCESSOR, OP_VECTOR_REF,2,0, SEXP_VECTOR, SEXP_FIXNUM, 0,"vector-ref"), +_OP(OPC_ACCESSOR, OP_VECTOR_SET,3,0, SEXP_VECTOR, SEXP_FIXNUM, 0,"vector-set!"), +_OP(OPC_ACCESSOR, OP_STRING_REF,2,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-ref"), +_OP(OPC_ACCESSOR, OP_STRING_SET,3,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-set!"), +_OP(OPC_ARITHMETIC, OP_ADD, 0, 1, SEXP_FIXNUM, 0, 0, "+"), +_OP(OPC_ARITHMETIC_INV, OP_SUB, 0, 1, SEXP_FIXNUM, 0, OP_NEG, "-"), +_OP(OPC_ARITHMETIC, OP_MUL, 0, 1, SEXP_FIXNUM, 0, 0, "*"), +_OP(OPC_ARITHMETIC_INV, OP_DIV, 0, 1, SEXP_FIXNUM, 0, OP_INV, "/"), +_OP(OPC_ARITHMETIC, OP_MOD, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, 0, "%"), +_OP(OPC_ARITHMETIC_CMP, OP_LT, 0, 1, SEXP_FIXNUM, 0, 0, "<"), +_OP(OPC_ARITHMETIC_CMP, OP_LE, 0, 1, SEXP_FIXNUM, 0, 0, "<="), +_OP(OPC_ARITHMETIC_CMP, OP_GT, 0, 1, SEXP_FIXNUM, 0, 0, ">"), +_OP(OPC_ARITHMETIC_CMP, OP_GE, 0, 1, SEXP_FIXNUM, 0, 0, ">="), +_OP(OPC_ARITHMETIC_CMP, OP_EQN, 0, 1, SEXP_FIXNUM, 0, 0, "="), +_OP(OPC_PREDICATE, OP_EQ, 2, 0, 0, 0, 0, "eq?"), +_OP(OPC_CONSTRUCTOR, OP_CONS, 2, 0, 0, 0, 0, "cons"), +_OP(OPC_CONSTRUCTOR, OP_MAKE_VECTOR, 2, 0, SEXP_FIXNUM, 0, 0, "make-vector"), +_OP(OPC_CONSTRUCTOR, OP_MAKE_PROCEDURE, 2, 0, 0, 0, 0, "make-procedure"), +_OP(OPC_TYPE_PREDICATE, OP_PAIRP, 1, 0, 0, 0, 0, "pair?"), +_OP(OPC_TYPE_PREDICATE, OP_NULLP, 1, 0, 0, 0, 0, "null?"), +_OP(OPC_TYPE_PREDICATE, OP_STRINGP, 1, 0, 0, 0, 0, "string?"), +_OP(OPC_TYPE_PREDICATE, OP_SYMBOLP, 1, 0, 0, 0, 0, "symbol?"), +_OP(OPC_TYPE_PREDICATE, OP_CHARP, 1, 0, 0, 0, 0, "char?"), +_OP(OPC_TYPE_PREDICATE, OP_VECTORP, 1, 0, 0, 0, 0, "vector?"), +_OP(OPC_TYPE_PREDICATE, OP_PROCEDUREP, 1, 0, 0, 0, 0, "procedure?"), +_OP(OPC_TYPE_PREDICATE, OP_IPORTP, 1, 0, 0, 0, 0, "input-port?"), +_OP(OPC_TYPE_PREDICATE, OP_OPORTP, 1, 0, 0, 0, 0, "output-port?"), +_OP(OPC_TYPE_PREDICATE, OP_EOFP, 1, 0, 0, 0, 0, "eof-object?"), +_FN1(SEXP_PAIR, "reverse", sexp_reverse), +_FN1(SEXP_PAIR, "list->vector", sexp_list_to_vector), +_FN2(0, SEXP_PAIR, "memq", sexp_memq), +_FN2(0, SEXP_PAIR, "assq", sexp_assq), +_FN2(SEXP_PAIR, SEXP_PAIR, "diffq", sexp_lset_diff), +#undef _OP +#undef _FN +#undef _FN0 +#undef _FN1 +#undef _FN2 +}; + +env make_standard_env() { + int i; + env e = (env) SEXP_ALLOC(sizeof(struct env)); + e->tag = SEXP_ENV; + e->parent = NULL; + e->bindings = SEXP_NULL; + for (i=0; i<(sizeof(core_forms)/sizeof(struct core_form)); i++) { + env_define(e, sexp_intern(core_forms[i].name), (sexp)(&core_forms[i])); + } + for (i=0; i<(sizeof(opcodes)/sizeof(struct opcode)); i++) { + env_define(e, sexp_intern(opcodes[i].name), (sexp)(&opcodes[i])); + } + return e; +} + +/************************** eval interface ****************************/ + sexp eval_in_stack(sexp obj, env e, sexp* stack, unsigned int top) { bytecode bc; bc = compile(SEXP_NULL, sexp_cons(obj, SEXP_NULL), e, SEXP_NULL, SEXP_NULL, 1); @@ -765,6 +804,22 @@ void scheme_init() { } } +void repl (env e, sexp *stack) { + sexp obj, res; + while (1) { + fprintf(stdout, "> "); + fflush(stdout); + obj = sexp_read(cur_input_port); + if (obj == SEXP_EOF) + break; + res = eval_in_stack(obj, e, stack, 0); + if (res != SEXP_UNDEF) { + sexp_write(res, cur_output_port); + sexp_write_char('\n', cur_output_port); + } + } +} + int main (int argc, char **argv) { sexp obj, res, in, out, *stack; env e; @@ -793,21 +848,7 @@ int main (int argc, char **argv) { } } - /* repl */ - while (! quit) { - fprintf(stdout, "> "); - fflush(stdout); - obj = sexp_read(cur_input_port); - if (obj == SEXP_EOF) { - quit = 1; - } else { - res = eval_in_stack(obj, e, stack, 0); - if (res != SEXP_UNDEF) { - sexp_write(res, cur_output_port); - sexp_write_char('\n', cur_output_port); - } - } - } + repl(e, stack); return 0; } diff --git a/eval.h b/eval.h index 29b758c0..e0acef50 100644 --- a/eval.h +++ b/eval.h @@ -2,8 +2,8 @@ /* Copyright (c) 2009 Alex Shinn. All rights reserved. */ /* BSD-style license: http://synthcode.com/license.txt */ -#ifndef SCM_EVAL_H -#define SCM_EVAL_H +#ifndef SEXP_EVAL_H +#define SEXP_EVAL_H #include "sexp.h" @@ -14,6 +14,15 @@ #define sexp_debug(msg, obj) (sexp_write_string(msg,cur_error_port), sexp_write(obj, cur_error_port), sexp_write_char('\n',cur_error_port)) +typedef sexp (*sexp_proc0) (); +typedef sexp (*sexp_proc1) (sexp); +typedef sexp (*sexp_proc2) (sexp, sexp); +typedef sexp (*sexp_proc3) (sexp, sexp, sexp); +typedef sexp (*sexp_proc4) (sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc5) (sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc6) (sexp, sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc7) (sexp, sexp, sexp, sexp, sexp, sexp, sexp); + typedef struct bytecode { char tag; unsigned int len; @@ -37,15 +46,16 @@ typedef struct opcode { char var_args_p; char arg1_type; char arg2_type; - char* name; char op_inverse; + char* name; + sexp data; sexp proc; } *opcode; typedef struct core_form { char tag; - char* name; char code; + char* name; } *core_form; enum core_form_names { @@ -69,11 +79,21 @@ enum opcode_classes { OPC_ARITHMETIC_CMP, OPC_CONSTRUCTOR, OPC_ACCESSOR, + OPC_FOREIGN, }; enum opcode_names { OP_NOOP, OP_CALL, + OP_FCALL0, + OP_FCALL1, + OP_FCALL2, + OP_FCALL3, + OP_FCALL4, + OP_FCALL5, + OP_FCALL6, + OP_FCALL7, + OP_FCALLN, OP_JUMP_UNLESS, OP_JUMP, OP_RET, @@ -102,6 +122,8 @@ enum opcode_names { OP_CHARP, OP_EOFP, OP_PROCEDUREP, + OP_IPORTP, + OP_OPORTP, OP_CAR, OP_CDR, OP_SET_CAR, @@ -139,5 +161,5 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top); sexp eval_in_stack(sexp obj, env e, sexp* stack, unsigned int top); sexp eval(sexp obj, env e); -#endif /* ! SCM_EVAL_H */ +#endif /* ! SEXP_EVAL_H */ diff --git a/sexp.c b/sexp.c index eb180664..d5275838 100644 --- a/sexp.c +++ b/sexp.c @@ -252,25 +252,26 @@ sexp sexp_intern(char *str) { } symbol_table_count++; - resize: 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; } - new_entry: sym = SEXP_NEW(); - if (! sym) return SEXP_ERROR; + if (! sym) { return SEXP_ERROR; } len = strlen(str); mystr = SEXP_ALLOC(len+1); if (! mystr) { SEXP_FREE(sym); return SEXP_ERROR; } memcpy(mystr, str, len+1); + mystr[len]=0; sym->tag = SEXP_SYMBOL; sym->data1 = (void*) len; sym->data2 = (void*) mystr; - symbol_table[cell] = (sexp) (((sexp_uint_t)sym) + 3); + symbol_table[cell] = sym; return symbol_table[cell]; } @@ -381,7 +382,8 @@ sexp sexp_get_output_string(sexp port) { #endif void sexp_write (sexp obj, sexp out) { - unsigned long len, i, c, res; + unsigned long len, c, res; + long i; sexp x, *elts; char *str; diff --git a/sexp.h b/sexp.h index fed7ae22..e16b1abf 100644 --- a/sexp.h +++ b/sexp.h @@ -63,6 +63,7 @@ #define SEXP_CHAR_TAG 6 enum sexp_types { + SEXP_OBJECT, SEXP_FIXNUM, SEXP_CHAR, SEXP_BOOLEAN, @@ -174,7 +175,7 @@ void sexp_write_string(sexp str, sexp port); void sexp_printf(sexp port, sexp fmt, ...); #endif -#define sexp_symbol_pointer(x) ((sexp) (((sexp_uint_t)x)-SEXP_LSYMBOL_TAG)) +#define sexp_symbol_pointer(x) (x) #define sexp_symbol_length(x) ((sexp_uint_t) (sexp_symbol_pointer(x)->data1)) #define sexp_symbol_data(x) ((char*) (sexp_symbol_pointer(x)->data2)) @@ -205,8 +206,6 @@ void sexp_printf(sexp port, sexp fmt, ...); sexp sexp_cons(sexp head, sexp tail); sexp sexp_car(sexp obj); sexp sexp_cdr(sexp obj); -sexp sexp_set_car(sexp obj, sexp val); -sexp sexp_set_cdr(sexp obj, sexp val); int sexp_listp(sexp obj); int sexp_list_index(sexp ls, sexp elt); From df8bd4bc04622d8dfb3729007d9e1c69f74ddb78 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Fri, 6 Mar 2009 01:39:59 +0900 Subject: [PATCH 015/154] adding apply1 --- debug.c | 2 +- eval.c | 77 +++++++++++++++++++++++++++++++++++---------------------- eval.h | 1 + 3 files changed, 50 insertions(+), 30 deletions(-) diff --git a/debug.c b/debug.c index 3237b21f..cc388900 100644 --- a/debug.c +++ b/debug.c @@ -4,7 +4,7 @@ static const char* reverse_opcode_names[] = {"NOOP", "CALL", "FCALL0", "FCALL1", "FCALL2", "FCALL3", "FCALL4", "FCALL5", - "FCALL6", "FCALL7", "FCALLN", "JUMP_UNLESS", "JUMP", "RET", "DONE", + "FCALL6", "FCALL7", "FCALLN", "APPLY1", "JUMP_UNLESS", "JUMP", "RET", "DONE", "STACK_REF", "STACK_SET", "GLOBAL_REF", "GLOBAL_SET", "CLOSURE_REF", "VECTOR_REF", "VECTOR_SET", "STRING_REF", "STRING_SET", "MAKE_PROCEDURE", "MAKE_VECTOR", "PUSH", "DUP", "DROP", "SWAP", "PAIRP", "NULLP", "VECTORP", diff --git a/eval.c b/eval.c index 5ffd34b5..3e219c3c 100644 --- a/eval.c +++ b/eval.c @@ -20,23 +20,6 @@ static sexp exception_handler; #endif /********************** environment utilities ***************************/ - -sexp sexp_set_car(sexp obj, sexp val) { - if (SEXP_PAIRP(obj)) - return SEXP_CAR(obj) = val; - else { - sexp_debug("error: set-car! not a pair: ", obj); - return SEXP_ERROR; - } -} - -sexp sexp_set_cdr(sexp obj, sexp val) { - if (SEXP_PAIRP(obj)) - return SEXP_CDR(obj) = val; - else - return SEXP_ERROR; -} - sexp env_cell(env e, sexp key) { sexp ls, res=NULL; @@ -440,11 +423,29 @@ bytecode compile(sexp params, sexp obj, env e, sexp fv, sexp sv, int done_p) { return bc; } +/************************ library functions ***************************/ + +sexp sexp_set_car(sexp obj, sexp val) { + if (SEXP_PAIRP(obj)) + return SEXP_CAR(obj) = val; + else { + sexp_debug("error: set-car! not a pair: ", obj); + return SEXP_ERROR; + } +} + +sexp sexp_set_cdr(sexp obj, sexp val) { + if (SEXP_PAIRP(obj)) + return SEXP_CDR(obj) = val; + else + return SEXP_ERROR; +} + /*********************** the virtual machine **************************/ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { unsigned char *ip=bc->data; - sexp cp, tmp; + sexp cp, tmp1, tmp2; int i; loop: @@ -459,8 +460,8 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { /* fflush(stderr); */ /* sexp_write(stderr, ((sexp*)ip)[0]); */ /* fprintf(stderr, "\n"); */ - tmp = env_cell(e, ((sexp*)ip)[0]); - stack[top++]=SEXP_CDR(tmp); + tmp1 = env_cell(e, ((sexp*)ip)[0]); + stack[top++]=SEXP_CDR(tmp1); ip += sizeof(sexp); break; case OP_GLOBAL_SET: @@ -532,9 +533,9 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { top--; break; case OP_SWAP: - tmp = stack[top-2]; + tmp1 = stack[top-2]; stack[top-2]=stack[top-1]; - stack[top-1]=tmp; + stack[top-1]=tmp1; break; case OP_PAIRP: stack[top-1]=SEXP_PAIRP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break; @@ -620,23 +621,40 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { case OP_CALL: /* fprintf(stderr, "CALL\n"); */ i = (sexp_uint_t) ((sexp*)ip)[0]; - tmp = stack[top-1]; - if (! SEXP_PROCEDUREP(tmp)) - errx(2, "non-procedure application: %p", tmp); + tmp1 = stack[top-1]; + if (! SEXP_PROCEDUREP(tmp1)) + errx(2, "non-procedure application: %p", tmp1); stack[top-1] = (sexp) i; stack[top] = sexp_make_integer(ip+4); stack[top+1] = cp; top+=2; - bc = sexp_procedure_code(tmp); + bc = sexp_procedure_code(tmp1); /* print_bytecode(bc); */ /* disasm(bc); */ ip = bc->data; - cp = sexp_procedure_vars(tmp); + cp = sexp_procedure_vars(tmp1); fprintf(stderr, "... calling procedure at %p\ncp: ", ip); /* sexp_write(cp, stderr); */ fprintf(stderr, "\n"); - /* fprintf(stderr, "stack at %d\n", top); */ - /* print_stack(stack, top); */ + fprintf(stderr, "stack at %d\n", top); + print_stack(stack, top); + break; + case OP_APPLY1: + tmp1 = stack[top-1]; + if (! SEXP_PROCEDUREP(tmp1)) + errx(2, "non-procedure application: %p", tmp1); + tmp2 = stack[top-2]; + i = sexp_length(tmp2); + top += (i-2); + for ( ; SEXP_PAIRP(tmp2); tmp2=SEXP_CDR(tmp2), top--) + stack[top-1] = SEXP_CAR(tmp2); + top += i+3; + stack[top-3] = sexp_make_integer(i); + stack[top-2] = sexp_make_integer(ip); + stack[top-1] = cp; + bc = sexp_procedure_code(tmp1); + ip = bc->data; + cp = sexp_procedure_vars(tmp1); break; case OP_FCALL0: stack[top-1]=((sexp_proc0)stack[top-1])(); @@ -752,6 +770,7 @@ _OP(OPC_TYPE_PREDICATE, OP_PROCEDUREP, 1, 0, 0, 0, 0, "procedure?"), _OP(OPC_TYPE_PREDICATE, OP_IPORTP, 1, 0, 0, 0, 0, "input-port?"), _OP(OPC_TYPE_PREDICATE, OP_OPORTP, 1, 0, 0, 0, 0, "output-port?"), _OP(OPC_TYPE_PREDICATE, OP_EOFP, 1, 0, 0, 0, 0, "eof-object?"), +_OP(OPC_GENERIC, OP_APPLY1, 2, SEXP_PROCEDURE, SEXP_PAIR, 0, 0, "apply1"), _FN1(SEXP_PAIR, "reverse", sexp_reverse), _FN1(SEXP_PAIR, "list->vector", sexp_list_to_vector), _FN2(0, SEXP_PAIR, "memq", sexp_memq), diff --git a/eval.h b/eval.h index e0acef50..b3677280 100644 --- a/eval.h +++ b/eval.h @@ -94,6 +94,7 @@ enum opcode_names { OP_FCALL6, OP_FCALL7, OP_FCALLN, + OP_APPLY1, OP_JUMP_UNLESS, OP_JUMP, OP_RET, From dea136014bea50de0b4d00b5354bc64cb66b7d39 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Fri, 6 Mar 2009 16:52:11 +0900 Subject: [PATCH 016/154] initial call/cc support --- debug.c | 9 ++++---- eval.c | 68 +++++++++++++++++++++++++++++++++++++++++++++++++++++---- eval.h | 7 +++--- sexp.c | 8 +++---- sexp.h | 2 +- 5 files changed, 77 insertions(+), 17 deletions(-) diff --git a/debug.c b/debug.c index cc388900..8ab62646 100644 --- a/debug.c +++ b/debug.c @@ -1,10 +1,11 @@ -/* debug.c -- optional debugging utilities */ +/* debug.c -- optional debugging utilities */ /* Copyright (c) 2009 Alex Shinn. All rights reserved. */ -/* BSD-style license: http://synthcode.com/license.txt */ +/* BSD-style license: http://synthcode.com/license.txt */ static const char* reverse_opcode_names[] = - {"NOOP", "CALL", "FCALL0", "FCALL1", "FCALL2", "FCALL3", "FCALL4", "FCALL5", - "FCALL6", "FCALL7", "FCALLN", "APPLY1", "JUMP_UNLESS", "JUMP", "RET", "DONE", + {"NOOP", "CALL", "APPLY1", "CALLCC", "RESUMECC", "FCALL0", "FCALL1", + "FCALL2", "FCALL3", "FCALL4", "FCALL5", "FCALL6", "FCALL7", "FCALLN", + "JUMP_UNLESS", "JUMP", "RET", "DONE", "STACK_REF", "STACK_SET", "GLOBAL_REF", "GLOBAL_SET", "CLOSURE_REF", "VECTOR_REF", "VECTOR_SET", "STRING_REF", "STRING_SET", "MAKE_PROCEDURE", "MAKE_VECTOR", "PUSH", "DUP", "DROP", "SWAP", "PAIRP", "NULLP", "VECTORP", diff --git a/eval.c b/eval.c index 3e219c3c..bccd0162 100644 --- a/eval.c +++ b/eval.c @@ -10,6 +10,7 @@ static int scheme_initialized_p = 0; static sexp cur_input_port, cur_output_port, cur_error_port; static sexp exception_handler; +static sexp continuation_resumer; #ifdef USE_DEBUG #include "debug.c" @@ -443,9 +444,27 @@ sexp sexp_set_cdr(sexp obj, sexp val) { /*********************** the virtual machine **************************/ +sexp sexp_save_stack(sexp *stack, unsigned int to) { + sexp res, *data; + int i; + res = sexp_make_vector(to, SEXP_UNDEF); + data = sexp_vector_data(res); + for (i=0; idata; - sexp cp, tmp1, tmp2; + sexp cp=SEXP_UNDEF, tmp1, tmp2; int i; loop: @@ -636,8 +655,8 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { fprintf(stderr, "... calling procedure at %p\ncp: ", ip); /* sexp_write(cp, stderr); */ fprintf(stderr, "\n"); - fprintf(stderr, "stack at %d\n", top); - print_stack(stack, top); + /* fprintf(stderr, "stack at %d\n", top); */ + /* print_stack(stack, top); */ break; case OP_APPLY1: tmp1 = stack[top-1]; @@ -656,6 +675,39 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { ip = bc->data; cp = sexp_procedure_vars(tmp1); break; + case OP_CALLCC: + tmp1 = stack[top-1]; + if (! SEXP_PROCEDUREP(tmp1)) + errx(2, "non-procedure application: %p", tmp1); + stack[top] = sexp_make_integer(1); + stack[top+1] = sexp_make_integer(ip); + stack[top+2] = cp; + tmp2 = sexp_save_stack(stack, top+3); +/* fprintf(stderr, "saved: ", top); */ +/* sexp_write(tmp2, cur_error_port); */ +/* fprintf(stderr, "\n", top); */ + stack[top-1] = sexp_make_procedure(continuation_resumer, + sexp_vector(1, tmp2)); + top+=3; + bc = sexp_procedure_code(tmp1); + ip = bc->data; + cp = sexp_procedure_vars(tmp1); + break; + case OP_RESUMECC: +/* fprintf(stderr, "resuming continuation (%d)\n", top); */ +/* print_stack(stack, top); */ +/* sexp_write(sexp_vector_ref(cp, 0), cur_error_port); */ +/* fprintf(stderr, "\n"); */ + tmp1 = stack[top-4]; + top = sexp_restore_stack(sexp_vector_ref(cp, 0), stack); +/* fprintf(stderr, "... restored stack (%d):\n", top); */ +/* print_stack(stack, top); */ + cp = stack[top-1]; + ip = (unsigned char*) sexp_unbox_integer(stack[top-2]); + i = sexp_unbox_integer(stack[top-3]); + top -= 3; + stack[top-1] = tmp1; + break; case OP_FCALL0: stack[top-1]=((sexp_proc0)stack[top-1])(); break; @@ -718,7 +770,7 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { return stack[top-1]; } -/************************** eval interface ****************************/ +/*********************** standard environment *************************/ static const struct core_form core_forms[] = { {SEXP_CORE, CORE_DEFINE, "define"}, @@ -771,6 +823,7 @@ _OP(OPC_TYPE_PREDICATE, OP_IPORTP, 1, 0, 0, 0, 0, "input-port?"), _OP(OPC_TYPE_PREDICATE, OP_OPORTP, 1, 0, 0, 0, 0, "output-port?"), _OP(OPC_TYPE_PREDICATE, OP_EOFP, 1, 0, 0, 0, 0, "eof-object?"), _OP(OPC_GENERIC, OP_APPLY1, 2, SEXP_PROCEDURE, SEXP_PAIR, 0, 0, "apply1"), +_OP(OPC_GENERIC, OP_CALLCC, 1, SEXP_PROCEDURE, 0, 0, 0, "call-with-current-continuation"), _FN1(SEXP_PAIR, "reverse", sexp_reverse), _FN1(SEXP_PAIR, "list->vector", sexp_list_to_vector), _FN2(0, SEXP_PAIR, "memq", sexp_memq), @@ -814,12 +867,19 @@ sexp eval(sexp obj, env e) { } void scheme_init() { + bytecode bc; + unsigned int i=0; if (! scheme_initialized_p) { scheme_initialized_p = 1; sexp_init(); cur_input_port = sexp_make_input_port(stdin); cur_output_port = sexp_make_output_port(stdout); cur_error_port = sexp_make_output_port(stderr); + bc = (bytecode) SEXP_ALLOC(sizeof(struct bytecode)+16); + bc->tag = SEXP_BYTECODE; + bc->len = 16; + emit(&bc, &i, OP_RESUMECC); + continuation_resumer = (sexp) bc; } } diff --git a/eval.h b/eval.h index b3677280..849e4564 100644 --- a/eval.h +++ b/eval.h @@ -29,9 +29,6 @@ typedef struct bytecode { unsigned char data[]; } *bytecode; -/* env binding: #(id chain offset flags) */ -/* chain is the index into the closure parent list (0 for current lambda) */ -/* macros/constants have a value instead of chain */ typedef struct env { char tag; struct env *parent; @@ -85,6 +82,9 @@ enum opcode_classes { enum opcode_names { OP_NOOP, OP_CALL, + OP_APPLY1, + OP_CALLCC, + OP_RESUMECC, OP_FCALL0, OP_FCALL1, OP_FCALL2, @@ -94,7 +94,6 @@ enum opcode_names { OP_FCALL6, OP_FCALL7, OP_FCALLN, - OP_APPLY1, OP_JUMP_UNLESS, OP_JUMP, OP_RET, diff --git a/sexp.c b/sexp.c index d5275838..497d2cc6 100644 --- a/sexp.c +++ b/sexp.c @@ -275,7 +275,7 @@ sexp sexp_intern(char *str) { return symbol_table[cell]; } -sexp sexp_make_vector(unsigned long len, sexp dflt) { +sexp sexp_make_vector(unsigned int len, sexp dflt) { int i; sexp v = SEXP_NEW(); if (v == NULL) return SEXP_ERROR; @@ -411,10 +411,10 @@ void sexp_write (sexp obj, sexp out) { sexp_write_string("#()", out); } else { sexp_write_string("#(", out); - sexp_write(out, elts[0]); + sexp_write(elts[0], out); for (i=1; i", out); break; default: - sexp_write_string("#", out); + sexp_printf(out, "#", obj); } } } diff --git a/sexp.h b/sexp.h index e16b1abf..565f1389 100644 --- a/sexp.h +++ b/sexp.h @@ -221,7 +221,7 @@ sexp sexp_make_string(char *str); sexp sexp_make_flonum(double f); int sexp_string_hash(char *str, int acc); sexp sexp_intern(char *str); -sexp sexp_make_vector(unsigned long len, sexp dflt); +sexp sexp_make_vector(unsigned int len, sexp dflt); sexp sexp_list_to_vector(sexp ls); sexp sexp_vector(int count, ...); void sexp_write(sexp obj, sexp out); From c0da696c676545699b498be3ecf80b2e418c5b3a Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Fri, 6 Mar 2009 20:02:45 +0900 Subject: [PATCH 017/154] initial exception system --- debug.c | 2 +- eval.c | 41 ++++++++++++++++++++++++++++++++++------- eval.h | 1 + sexp.c | 13 +++++++++++-- 4 files changed, 47 insertions(+), 10 deletions(-) diff --git a/debug.c b/debug.c index 8ab62646..a9486f2f 100644 --- a/debug.c +++ b/debug.c @@ -3,7 +3,7 @@ /* BSD-style license: http://synthcode.com/license.txt */ static const char* reverse_opcode_names[] = - {"NOOP", "CALL", "APPLY1", "CALLCC", "RESUMECC", "FCALL0", "FCALL1", + {"NOOP", "CALL", "APPLY1", "CALLCC", "RESUMECC", "ERROR", "FCALL0", "FCALL1", "FCALL2", "FCALL3", "FCALL4", "FCALL5", "FCALL6", "FCALL7", "FCALLN", "JUMP_UNLESS", "JUMP", "RET", "DONE", "STACK_REF", "STACK_SET", "GLOBAL_REF", "GLOBAL_SET", "CLOSURE_REF", diff --git a/eval.c b/eval.c index bccd0162..4662d054 100644 --- a/eval.c +++ b/eval.c @@ -9,7 +9,7 @@ static int scheme_initialized_p = 0; static sexp cur_input_port, cur_output_port, cur_error_port; -static sexp exception_handler; +static sexp exception_handler_cell; static sexp continuation_resumer; #ifdef USE_DEBUG @@ -206,7 +206,7 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, case OPC_ACCESSOR: case OPC_GENERIC: if (SEXP_NULLP(SEXP_CDR(obj))) { - errx(1, "unknown opcode class: %d", ((opcode)o1)->op_class); + errx(1, "opcode with no arguments: %s", ((opcode)o1)->name); } else if (SEXP_NULLP(SEXP_CDDR(obj))) { if (((opcode)o1)->op_class == OPC_ARITHMETIC_INV) { analyze(SEXP_CADR(obj), bc, i, e, params, fv, sv, d); @@ -259,7 +259,7 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, } } else if (SEXP_SYMBOLP(obj)) { analyze_var_ref(obj, bc, i, e, params, fv, sv, d); - } else { + } else { /* literal */ emit_push(bc, i, obj); (*d)++; } @@ -708,6 +708,21 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { top -= 3; stack[top-1] = tmp1; break; + case OP_ERROR: + call_error_handler: + sexp_write_string("ERROR: ", cur_error_port); + sexp_write(stack[top-1], cur_error_port); + sexp_write_string("\n", cur_error_port); + tmp1 = SEXP_CDR(exception_handler_cell); + stack[top-1] = SEXP_UNDEF; + stack[top] = (sexp) 1; + stack[top+1] = sexp_make_integer(ip+4); + stack[top+2] = cp; + top+=3; + bc = sexp_procedure_code(tmp1); + ip = bc->data; + cp = sexp_procedure_vars(tmp1); + break; case OP_FCALL0: stack[top-1]=((sexp_proc0)stack[top-1])(); break; @@ -824,6 +839,7 @@ _OP(OPC_TYPE_PREDICATE, OP_OPORTP, 1, 0, 0, 0, 0, "output-port?"), _OP(OPC_TYPE_PREDICATE, OP_EOFP, 1, 0, 0, 0, 0, "eof-object?"), _OP(OPC_GENERIC, OP_APPLY1, 2, SEXP_PROCEDURE, SEXP_PAIR, 0, 0, "apply1"), _OP(OPC_GENERIC, OP_CALLCC, 1, SEXP_PROCEDURE, 0, 0, 0, "call-with-current-continuation"), +_OP(OPC_GENERIC, OP_ERROR, 1, SEXP_STRING, 0, 0, 0, "error"), _FN1(SEXP_PAIR, "reverse", sexp_reverse), _FN1(SEXP_PAIR, "list->vector", sexp_list_to_vector), _FN2(0, SEXP_PAIR, "memq", sexp_memq), @@ -900,13 +916,24 @@ void repl (env e, sexp *stack) { } int main (int argc, char **argv) { - sexp obj, res, in, out, *stack; + sexp obj, res, in, out, *stack, err_handler, err_handler_sym; env e; - int i, quit=0; + bytecode bc; + unsigned int i, quit=0; scheme_init(); - e = make_standard_env(); stack = (sexp*) SEXP_ALLOC(sizeof(sexp) * INIT_STACK_SIZE); + e = make_standard_env(); + bc = (bytecode) SEXP_ALLOC(sizeof(struct bytecode)+16); + bc->tag = SEXP_BYTECODE; + bc->len = 16; + i = 0; + emit_push(&bc, &i, (sexp_uint_t) SEXP_UNDEF); + emit(&bc, &i, OP_DONE); + err_handler = sexp_make_procedure((sexp)bc, sexp_make_vector(0, SEXP_UNDEF)); + err_handler_sym = sexp_intern("*error-handler*"); + env_define(e, err_handler_sym, err_handler); + exception_handler_cell = env_cell(e, err_handler_sym); /* parse options */ for (i=1; i < argc && argv[i][0] == '-'; i++) { @@ -927,7 +954,7 @@ int main (int argc, char **argv) { } } - repl(e, stack); + if (! quit) repl(e, stack); return 0; } diff --git a/eval.h b/eval.h index 849e4564..045e3af0 100644 --- a/eval.h +++ b/eval.h @@ -85,6 +85,7 @@ enum opcode_names { OP_APPLY1, OP_CALLCC, OP_RESUMECC, + OP_ERROR, OP_FCALL0, OP_FCALL1, OP_FCALL2, diff --git a/sexp.c b/sexp.c index 497d2cc6..2e9db9f4 100644 --- a/sexp.c +++ b/sexp.c @@ -23,6 +23,7 @@ static sexp the_quote_symbol; static sexp the_quasiquote_symbol; static sexp the_unquote_symbol; static sexp the_unquote_splicing_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 */ @@ -277,9 +278,11 @@ sexp sexp_intern(char *str) { sexp sexp_make_vector(unsigned int len, sexp dflt) { int i; - sexp v = SEXP_NEW(); + sexp v, *x; + if (! len) return the_empty_vector; + v = SEXP_NEW(); if (v == NULL) return SEXP_ERROR; - sexp *x = (void*) SEXP_ALLOC(len*sizeof(sexp)); + x = (void*) SEXP_ALLOC(len*sizeof(sexp)); if (x == NULL) return SEXP_ERROR; for (i=0; i", out); break; case (sexp_uint_t) SEXP_UNDEF: sexp_write_string("#", out); break; + case (sexp_uint_t) SEXP_ERROR: + sexp_write_string("#", out); break; default: sexp_printf(out, "#", obj); } @@ -776,6 +781,10 @@ void sexp_init() { the_quasiquote_symbol = sexp_intern("quasiquote"); the_unquote_symbol = sexp_intern("unquote"); the_unquote_splicing_symbol = sexp_intern("unquote-splicing"); + the_empty_vector = SEXP_NEW(); + the_empty_vector->tag = SEXP_VECTOR; + the_empty_vector->data1 = 0; + the_empty_vector->data2 = 0; } } From a094fb3ff85aab33acf1ac56a67f279991729738 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 7 Mar 2009 15:52:42 +0900 Subject: [PATCH 018/154] raising exceptions on primitive cons cell accessors --- eval.c | 50 ++++++++++++++++++++------------------------------ sexp.c | 10 +--------- sexp.h | 5 ++--- 3 files changed, 23 insertions(+), 42 deletions(-) diff --git a/eval.c b/eval.c index 4662d054..201aeb3a 100644 --- a/eval.c +++ b/eval.c @@ -21,7 +21,7 @@ static sexp continuation_resumer; #endif /********************** environment utilities ***************************/ -sexp env_cell(env e, sexp key) { +static sexp env_cell(env e, sexp key) { sexp ls, res=NULL; do { @@ -37,7 +37,7 @@ sexp env_cell(env e, sexp key) { return res; } -int env_global_p (env e, sexp id) { +static int env_global_p (env e, sexp id) { while (e->parent) { if (sexp_assq(id, e->bindings) != SEXP_FALSE) return 0; @@ -47,7 +47,7 @@ int env_global_p (env e, sexp id) { return 1; } -void env_define(env e, sexp key, sexp value) { +static void env_define(env e, sexp key, sexp value) { sexp cell = env_cell(e, key); if (cell) { SEXP_CDR(cell) = value; @@ -56,7 +56,7 @@ void env_define(env e, sexp key, sexp value) { } } -env extend_env_closure (env e, sexp fv) { +static env extend_env_closure (env e, sexp fv) { int i; env e2 = (env) SEXP_ALLOC(sizeof(struct env)); e2->tag = SEXP_ENV; @@ -71,7 +71,7 @@ env extend_env_closure (env e, sexp fv) { /************************* bytecode utilities ***************************/ -void shrink_bcode(bytecode *bc, unsigned int i) { +static void shrink_bcode(bytecode *bc, unsigned int i) { bytecode tmp; if ((*bc)->len != i) { /* fprintf(stderr, "shrinking to %d\n", i); */ @@ -84,7 +84,7 @@ void shrink_bcode(bytecode *bc, unsigned int i) { } } -void emit(bytecode *bc, unsigned int *i, char c) { +static void emit(bytecode *bc, unsigned int *i, char c) { bytecode tmp; if ((*bc)->len < (*i)+1) { /* fprintf(stderr, "expanding (%d < %d)\n", (*bc)->len, (*i)+1); */ @@ -97,7 +97,7 @@ void emit(bytecode *bc, unsigned int *i, char c) { (*bc)->data[(*i)++] = c; } -void emit_word(bytecode *bc, unsigned int *i, sexp_uint_t val) { +static void emit_word(bytecode *bc, unsigned int *i, sexp_uint_t val) { bytecode tmp; if ((*bc)->len < (*i)+4) { tmp = (bytecode) SEXP_ALLOC(sizeof(unsigned int) + (*bc)->len*2); @@ -112,7 +112,7 @@ void emit_word(bytecode *bc, unsigned int *i, sexp_uint_t val) { #define emit_push(bc,i,obj) (emit(bc,i,OP_PUSH), emit_word(bc,i,(sexp_uint_t)obj)) -sexp sexp_make_procedure(sexp bc, sexp vars) { +static sexp sexp_make_procedure(sexp bc, sexp vars) { sexp proc = SEXP_NEW(); if (! proc) return SEXP_ERROR; proc->tag = SEXP_PROCEDURE; @@ -426,22 +426,6 @@ bytecode compile(sexp params, sexp obj, env e, sexp fv, sexp sv, int done_p) { /************************ library functions ***************************/ -sexp sexp_set_car(sexp obj, sexp val) { - if (SEXP_PAIRP(obj)) - return SEXP_CAR(obj) = val; - else { - sexp_debug("error: set-car! not a pair: ", obj); - return SEXP_ERROR; - } -} - -sexp sexp_set_cdr(sexp obj, sexp val) { - if (SEXP_PAIRP(obj)) - return SEXP_CDR(obj) = val; - else - return SEXP_ERROR; -} - /*********************** the virtual machine **************************/ sexp sexp_save_stack(sexp *stack, unsigned int to) { @@ -462,6 +446,8 @@ unsigned int sexp_restore_stack(sexp saved, sexp *current) { return len; } +#define sexp_raise(exn) {stack[top-1]=(exn); goto call_error_handler;} + sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { unsigned char *ip=bc->data; sexp cp=SEXP_UNDEF, tmp1, tmp2; @@ -579,16 +565,20 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { case OP_EOFP: stack[top-1]=(stack[top-1] == SEXP_EOF) ? SEXP_TRUE : SEXP_FALSE; break; case OP_CAR: - stack[top-1]=sexp_car(stack[top-1]); break; + if (! SEXP_PAIRP(stack[top-1])) sexp_raise(sexp_intern("not-a-pair")); + stack[top-1]=SEXP_CAR(stack[top-1]); break; case OP_CDR: - stack[top-1]=sexp_cdr(stack[top-1]); break; + if (! SEXP_PAIRP(stack[top-1])) sexp_raise(sexp_intern("not-a-pair")); + stack[top-1]=SEXP_CDR(stack[top-1]); break; case OP_SET_CAR: - sexp_set_car(stack[top-1], stack[top-2]); + if (! SEXP_PAIRP(stack[top-1])) sexp_raise(sexp_intern("not-a-pair")); + SEXP_CAR(stack[top-1]) = stack[top-2]; stack[top-2]=SEXP_UNDEF; top--; break; case OP_SET_CDR: - sexp_set_cdr(stack[top-1], stack[top-2]); + if (! SEXP_PAIRP(stack[top-1])) sexp_raise(sexp_intern("not-a-pair")); + SEXP_CDR(stack[top-1]) = stack[top-2]; stack[top-2]=SEXP_UNDEF; top--; break; @@ -902,8 +892,8 @@ void scheme_init() { void repl (env e, sexp *stack) { sexp obj, res; while (1) { - fprintf(stdout, "> "); - fflush(stdout); + sexp_write_string("> ", cur_output_port); + sexp_flush(cur_output_port); obj = sexp_read(cur_input_port); if (obj == SEXP_EOF) break; diff --git a/sexp.c b/sexp.c index 2e9db9f4..32e61c3c 100644 --- a/sexp.c +++ b/sexp.c @@ -85,14 +85,6 @@ sexp sexp_cons(sexp head, sexp tail) { return pair; } -sexp sexp_car(sexp obj) { - return (SEXP_PAIRP(obj)) ? SEXP_CAR(obj) : SEXP_ERROR; -} - -sexp sexp_cdr(sexp obj) { - return (SEXP_PAIRP(obj)) ? SEXP_CDR(obj) : SEXP_ERROR; -} - int sexp_listp (sexp obj) { while (SEXP_PAIRP(obj)) obj = SEXP_CDR(obj); @@ -444,7 +436,7 @@ void sexp_write (sexp obj, sexp out) { i = sexp_symbol_length(obj); str = sexp_symbol_data(obj); } - for ( ; i>=0; str++, i--) { + for ( ; i>0; str++, i--) { if (str[0] == '\\') sexp_write_char('\\', out); sexp_write_char(str[0], out); diff --git a/sexp.h b/sexp.h index 565f1389..719c91a5 100644 --- a/sexp.h +++ b/sexp.h @@ -76,6 +76,7 @@ enum sexp_types { SEXP_IPORT, SEXP_OPORT, /* the following are used only by the evaluator */ + SEXP_EXCEPTION, SEXP_PROCEDURE, SEXP_ENV, SEXP_BYTECODE, @@ -167,6 +168,7 @@ int sstream_close(void *vec); #define sexp_write_char(c, p) (putc(c, sexp_port_stream(p))) #define sexp_write_string(s, p) (fputs(s, sexp_port_stream(p))) #define sexp_printf(p, s, ...) (fprintf(sexp_port_stream(p), s, __VA_ARGS__)) +#define sexp_flush(p) (fflush(sexp_port_stream(p))) #else sexp sexp_read_char(sexp port); void sexp_push_char(sexp ch, sexp port); @@ -204,9 +206,6 @@ void sexp_printf(sexp port, sexp fmt, ...); #define SEXP_CDDDDR(x) (SEXP_CDDR(SEXP_CDDR(x))) sexp sexp_cons(sexp head, sexp tail); -sexp sexp_car(sexp obj); -sexp sexp_cdr(sexp obj); - int sexp_listp(sexp obj); int sexp_list_index(sexp ls, sexp elt); sexp sexp_lset_diff(sexp a, sexp b); From 09bbe9ac2ebb9797b363030c9ab6dc2257bac89c Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 8 Mar 2009 00:24:46 +0900 Subject: [PATCH 019/154] adding i/o port parameters --- config.h | 21 ++++++++++++++++----- debug.c | 3 ++- eval.c | 41 ++++++++++++++++++----------------------- eval.h | 2 ++ sexp.c | 8 ++++---- sexp.h | 14 ++++++++------ 6 files changed, 50 insertions(+), 39 deletions(-) diff --git a/config.h b/config.h index 1c739fae..625d3117 100644 --- a/config.h +++ b/config.h @@ -1,9 +1,20 @@ -/* config.h -- general configuration */ +/* config.h -- general configuration */ /* Copyright (c) 2009 Alex Shinn. All rights reserved. */ -/* BSD-style license: http://synthcode.com/license.txt */ +/* BSD-style license: http://synthcode.com/license.txt */ +#ifndef USE_BOEHM #define USE_BOEHM 1 -#define USE_HUFF_SYMS 1 -#define USE_DEBUG 1 -#define USE_STRING_STREAMS 1 +#endif + +#ifndef USE_HUFF_SYMS +#define USE_HUFF_SYMS 1 +#endif + +#ifndef USE_DEBUG +#define USE_DEBUG 1 +#endif + +#ifndef USE_STRING_STREAMS +#define USE_STRING_STREAMS 1 +#endif diff --git a/debug.c b/debug.c index a9486f2f..09c5f718 100644 --- a/debug.c +++ b/debug.c @@ -5,7 +5,7 @@ static const char* reverse_opcode_names[] = {"NOOP", "CALL", "APPLY1", "CALLCC", "RESUMECC", "ERROR", "FCALL0", "FCALL1", "FCALL2", "FCALL3", "FCALL4", "FCALL5", "FCALL6", "FCALL7", "FCALLN", - "JUMP_UNLESS", "JUMP", "RET", "DONE", + "JUMP_UNLESS", "JUMP", "RET", "DONE", "PARAMETER", "STACK_REF", "STACK_SET", "GLOBAL_REF", "GLOBAL_SET", "CLOSURE_REF", "VECTOR_REF", "VECTOR_SET", "STRING_REF", "STRING_SET", "MAKE_PROCEDURE", "MAKE_VECTOR", "PUSH", "DUP", "DROP", "SWAP", "PAIRP", "NULLP", "VECTORP", @@ -26,6 +26,7 @@ void disasm (bytecode bc) { case OP_STACK_REF: case OP_STACK_SET: case OP_CLOSURE_REF: + case OP_PARAMETER: fprintf(stderr, "%d", (long) ((sexp*)ip)[0]); ip += sizeof(sexp); break; diff --git a/eval.c b/eval.c index 201aeb3a..1f4e20f1 100644 --- a/eval.c +++ b/eval.c @@ -12,7 +12,7 @@ static sexp cur_input_port, cur_output_port, cur_error_port; static sexp exception_handler_cell; static sexp continuation_resumer; -#ifdef USE_DEBUG +#if USE_DEBUG #include "debug.c" #else #define print_stack(...) @@ -228,6 +228,10 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, (*d) -= sexp_length(SEXP_CDDR(obj)); } break; + case OPC_PARAMETER: + emit(bc, i, ((opcode)o1)->op_name); + emit_word(bc, i, (sexp_uint_t) ((opcode)o1)->data); + break; case OPC_FOREIGN: for (o2 = sexp_reverse(SEXP_CDR(obj)); SEXP_PAIRP(o2); o2 = SEXP_CDR(o2)) { @@ -454,35 +458,20 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { int i; loop: - /* fprintf(stderr, "opcode: %s (%d), ip: %d\n", reverse_opcode_names[*ip], *ip, ip); */ - /* print_bytecode(bc); */ switch (*ip++) { case OP_NOOP: fprintf(stderr, "noop\n"); break; case OP_GLOBAL_REF: -/* fprintf(stderr, "global ref: ip: %p => %p: ", ip, ((sexp*)ip)[0]); */ -/* fflush(stderr); */ -/* sexp_write(stderr, ((sexp*)ip)[0]); */ -/* fprintf(stderr, "\n"); */ tmp1 = env_cell(e, ((sexp*)ip)[0]); stack[top++]=SEXP_CDR(tmp1); ip += sizeof(sexp); break; case OP_GLOBAL_SET: -/* fprintf(stderr, "global set: %p: ", ((sexp*)ip)[0]); */ -/* fflush(stderr); */ -/* sexp_write(stderr, ((sexp*)ip)[0]); */ -/* fprintf(stderr, "\n"); */ env_define(e, ((sexp*)ip)[0], stack[--top]); ip += sizeof(sexp); break; case OP_STACK_REF: -/* fprintf(stderr, "stack ref: ip=%p, %d - %d => ", */ -/* ip, top, (sexp_uint_t) ((sexp*)ip)[0]); */ -/* fflush(stderr); */ -/* sexp_write(stderr, stack[top - (unsigned int) ((sexp*)ip)[0]]); */ -/* fprintf(stderr, "\n"); */ stack[top] = stack[top - (unsigned int) ((sexp*)ip)[0]]; ip += sizeof(sexp); top++; @@ -493,10 +482,6 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { ip += sizeof(sexp); break; case OP_CLOSURE_REF: -/* fprintf(stderr, "closure-ref %d => ", ((sexp*)ip)[0]); */ -/* fflush(stderr); */ -/* sexp_write(stderr, vector_ref(cp,((sexp*)ip)[0])); */ -/* fprintf(stderr, "\n"); */ stack[top++]=sexp_vector_ref(cp,((sexp*)ip)[0]); ip += sizeof(sexp); break; @@ -542,6 +527,11 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { stack[top-2]=stack[top-1]; stack[top-1]=tmp1; break; + case OP_PARAMETER: + stack[top] = *(sexp*)((sexp*)ip)[0]; + top++; + ip += sizeof(sexp); + break; case OP_PAIRP: stack[top-1]=SEXP_PAIRP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break; case OP_NULLP: @@ -748,8 +738,6 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { sexp_write(stack[top-1], cur_error_port); fprintf(stderr, "...\n"); /* print_stack(stack, top); */ - /* top-1 */ - /* stack: args ... n ip result */ cp = stack[top-2]; ip = (unsigned char*) sexp_unbox_integer(stack[top-3]); i = sexp_unbox_integer(stack[top-4]); @@ -795,6 +783,7 @@ static const struct opcode opcodes[] = { #define _FN0(s, f) _FN(OP_FCALL0, 0, 0, 0, s, f) #define _FN1(t, s, f) _FN(OP_FCALL1, 1, t, 0, s, f) #define _FN2(t, u, s, f) _FN(OP_FCALL2, 2, t, u, s, f) +#define _PARAM(n,a,t) {SEXP_OPCODE, OPC_PARAMETER, OP_PARAMETER, 0, 1, t, 0, 0, n, a, NULL} _OP(OPC_ACCESSOR, OP_CAR, 1, 0, SEXP_PAIR, 0, 0, "car"), _OP(OPC_ACCESSOR, OP_SET_CAR, 2, 0, SEXP_PAIR, 0, 0, "set-car!"), _OP(OPC_ACCESSOR, OP_CDR, 1, 0, SEXP_PAIR, 0, 0, "cdr"), @@ -827,7 +816,7 @@ _OP(OPC_TYPE_PREDICATE, OP_PROCEDUREP, 1, 0, 0, 0, 0, "procedure?"), _OP(OPC_TYPE_PREDICATE, OP_IPORTP, 1, 0, 0, 0, 0, "input-port?"), _OP(OPC_TYPE_PREDICATE, OP_OPORTP, 1, 0, 0, 0, 0, "output-port?"), _OP(OPC_TYPE_PREDICATE, OP_EOFP, 1, 0, 0, 0, 0, "eof-object?"), -_OP(OPC_GENERIC, OP_APPLY1, 2, SEXP_PROCEDURE, SEXP_PAIR, 0, 0, "apply1"), +_OP(OPC_GENERIC, OP_APPLY1, 2, 0, SEXP_PROCEDURE, SEXP_PAIR, 0, "apply1"), _OP(OPC_GENERIC, OP_CALLCC, 1, SEXP_PROCEDURE, 0, 0, 0, "call-with-current-continuation"), _OP(OPC_GENERIC, OP_ERROR, 1, SEXP_STRING, 0, 0, 0, "error"), _FN1(SEXP_PAIR, "reverse", sexp_reverse), @@ -835,11 +824,15 @@ _FN1(SEXP_PAIR, "list->vector", sexp_list_to_vector), _FN2(0, SEXP_PAIR, "memq", sexp_memq), _FN2(0, SEXP_PAIR, "assq", sexp_assq), _FN2(SEXP_PAIR, SEXP_PAIR, "diffq", sexp_lset_diff), +_PARAM("current-input-port", (sexp)&cur_input_port, SEXP_IPORT), +_PARAM("current-output-port", (sexp)&cur_output_port, SEXP_OPORT), +_PARAM("current-error-port", (sexp)&cur_error_port, SEXP_OPORT), #undef _OP #undef _FN #undef _FN0 #undef _FN1 #undef _FN2 +#undef _PARAM }; env make_standard_env() { @@ -925,6 +918,8 @@ int main (int argc, char **argv) { env_define(e, err_handler_sym, err_handler); exception_handler_cell = env_cell(e, err_handler_sym); + fprintf(stderr, "current-input-port: %d => %d\n", &cur_input_port, cur_input_port); + /* parse options */ for (i=1; i < argc && argv[i][0] == '-'; i++) { switch (argv[i][1]) { diff --git a/eval.h b/eval.h index 045e3af0..e8b9b2e3 100644 --- a/eval.h +++ b/eval.h @@ -76,6 +76,7 @@ enum opcode_classes { OPC_ARITHMETIC_CMP, OPC_CONSTRUCTOR, OPC_ACCESSOR, + OPC_PARAMETER, OPC_FOREIGN, }; @@ -99,6 +100,7 @@ enum opcode_names { OP_JUMP, OP_RET, OP_DONE, + OP_PARAMETER, OP_STACK_REF, OP_STACK_SET, OP_GLOBAL_REF, diff --git a/sexp.c b/sexp.c index 32e61c3c..2101681d 100644 --- a/sexp.c +++ b/sexp.c @@ -215,7 +215,7 @@ sexp sexp_intern(char *str) { char c, *mystr, *p=str; sexp sym, *newtable; -#ifdef USE_HUFF_SYMS +#if USE_HUFF_SYMS res = 0; for (p=str; c=*p; p++) { he = huff_table[c]; @@ -312,7 +312,7 @@ sexp sexp_vector(int count, ...) { /************************ reading and writing *************************/ -#ifdef USE_STRING_STREAMS +#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)); @@ -455,7 +455,7 @@ void sexp_write (sexp obj, sexp out) { } } else if (SEXP_SYMBOLP(obj)) { -#ifdef USE_HUFF_SYMS +#if USE_HUFF_SYMS if (((sexp_uint_t)obj&7)==7) { c = ((sexp_uint_t)obj)>>3; while (c) { @@ -764,7 +764,7 @@ sexp sexp_read_from_string(char *str) { void sexp_init() { if (! sexp_initialized_p) { sexp_initialized_p = 1; -#ifdef USE_BOEHM +#if USE_BOEHM GC_init(); #endif symbol_table = SEXP_ALLOC(symbol_table_primes[0]*sizeof(sexp)); diff --git a/sexp.h b/sexp.h index 719c91a5..8d15dbe3 100644 --- a/sexp.h +++ b/sexp.h @@ -13,7 +13,7 @@ #include "config.h" -#ifdef HAVE_ERR_H +#if HAVE_ERR_H #include #else /* requires that msg be a string literal */ @@ -21,10 +21,12 @@ #endif #if defined(__APPLE__) || defined(__FreeBSD__) || defined(__NetBSD__) || defined(__DragonFly__) || defined(__OpenBSD__) -#define SEXP_BSD +#define SEXP_BSD 1 +#else +#define SEXP_BSD 0 #endif -#ifdef USE_BOEHM +#if USE_BOEHM #include "gc/include/gc.h" #define SEXP_ALLOC GC_malloc #define SEXP_ALLOC_ATOMIC GC_malloc_atomic @@ -125,7 +127,7 @@ typedef long sexp_sint_t; #define SEXP_SYMBOLP(x) (SEXP_ISYMBOLP(x) || SEXP_LSYMBOLP(x)) -#ifdef USE_HUFF_SYMS +#if USE_HUFF_SYMS #define SEXP_DOTP(x) (((sexp_uint_t)(x))==((0x5D00<data1) -#ifdef USE_STRING_STREAMS -#ifdef SEXP_BSD +#if USE_STRING_STREAMS +#if SEXP_BSD #define fmemopen(str, len, m) funopen(sexp_vector(3, (sexp)str, (sexp)len, (sexp)0), sstream_read, sstream_write, sstream_seek, sstream_close) int sstream_read(void *vec, char *dst, int n); int sstream_write(void *vec, const char *src, int n); From 7795b773aad7ff5df974df7ddb432898f464a8fe Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 8 Mar 2009 00:55:32 +0900 Subject: [PATCH 020/154] initial variadic i/o routines --- debug.c | 15 +++++++++------ eval.c | 49 +++++++++++++++++++++++++++++++++++++++++++++++++ eval.h | 8 ++++++++ 3 files changed, 66 insertions(+), 6 deletions(-) diff --git a/debug.c b/debug.c index 09c5f718..831a9834 100644 --- a/debug.c +++ b/debug.c @@ -5,13 +5,16 @@ static const char* reverse_opcode_names[] = {"NOOP", "CALL", "APPLY1", "CALLCC", "RESUMECC", "ERROR", "FCALL0", "FCALL1", "FCALL2", "FCALL3", "FCALL4", "FCALL5", "FCALL6", "FCALL7", "FCALLN", - "JUMP_UNLESS", "JUMP", "RET", "DONE", "PARAMETER", - "STACK_REF", "STACK_SET", "GLOBAL_REF", "GLOBAL_SET", "CLOSURE_REF", - "VECTOR_REF", "VECTOR_SET", "STRING_REF", "STRING_SET", "MAKE_PROCEDURE", - "MAKE_VECTOR", "PUSH", "DUP", "DROP", "SWAP", "PAIRP", "NULLP", "VECTORP", + "JUMP-UNLESS", "JUMP", "RET", "DONE", "PARAMETER", + "STACK-REF", "STACK-SET", "GLOBAL-REF", "GLOBAL-SET", "CLOSURE-REF", + "VECTOR-REF", "VECTOR-SET", "STRING-REF", "STRING-SET", "MAKE-PROCEDURE", + "MAKE-VECTOR", "PUSH", "DUP", "DROP", "SWAP", "PAIRP", "NULLP", "VECTORP", "INTEGERP", "SYMBOLP", "STRINGP", "CHARP", "EOFP", "PROCEDUREP", "IPORTP", - "OPORTP", "CAR", "CDR", "SET_CAR", "SET_CDR", "CONS", "ADD", "SUB", "MUL", - "DIV", "MOD", "NEG", "INV", "LT", "LE", "GT", "GE", "EQN", "EQ",}; + "OPORTP", "CAR", "CDR", "SET-CAR", "SET-CDR", "CONS", "ADD", "SUB", "MUL", + "DIV", "MOD", "NEG", "INV", "LT", "LE", "GT", "GE", "EQN", "EQ", + "DISPLAY", "WRITE", "WRITE-CHAR", "NEWLINE", "FLUSH-OUTPUT", "READ", + "READ-CHAR", + }; void disasm (bytecode bc) { unsigned char *ip=bc->data, opcode; diff --git a/eval.c b/eval.c index 1f4e20f1..08a122d4 100644 --- a/eval.c +++ b/eval.c @@ -228,6 +228,19 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, (*d) -= sexp_length(SEXP_CDDR(obj)); } break; + case OPC_IO: + tmp1 = sexp_length(SEXP_CDR(obj)); + if (tmp1 == ((opcode)o1)->num_args && ((opcode)o1)->var_args_p) { + emit(bc, i, OP_PARAMETER); + emit_word(bc, i, (sexp_uint_t) ((opcode)o1)->data); + (*d)++; + } + for (o2 = sexp_reverse(SEXP_CDR(obj)); SEXP_PAIRP(o2); + o2 = SEXP_CDR(o2)) + analyze(SEXP_CAR(o2), bc, i, e, params, fv, sv, d); + emit(bc, i, ((opcode)o1)->op_name); + (*d) -= (tmp1-1); + break; case OPC_PARAMETER: emit(bc, i, ((opcode)o1)->op_name); emit_word(bc, i, (sexp_uint_t) ((opcode)o1)->data); @@ -732,6 +745,35 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { fprintf(stderr, "jumping to + %d => %d\n", ((signed char*)ip)[0], ip + ((signed char*)ip)[0]); ip += ((signed char*)ip)[0]; break; + case OP_DISPLAY: + if (SEXP_STRINGP(stack[top-1])) { + sexp_write_string(sexp_string_data(stack[top-1]), stack[top-2]); + break; + } + case OP_WRITE: + sexp_write(stack[top-1], stack[top-2]); + stack[top-2] = SEXP_UNDEF; + top--; + break; + case OP_WRITE_CHAR: + sexp_write_char(sexp_unbox_character(stack[top-1]), stack[top-2]); + break; + case OP_NEWLINE: + sexp_write_char('\n', stack[top-1]); + stack[top-1] = SEXP_UNDEF; + break; + case OP_FLUSH_OUTPUT: + sexp_flush(stack[top-1]); + stack[top-1] = SEXP_UNDEF; + break; + case OP_READ: + stack[top-1] = sexp_read(stack[top-1]); + if (stack[top-1] == SEXP_ERROR) sexp_raise(sexp_intern("read-error")); + break; + case OP_READ_CHAR: + i = sexp_read_char(stack[top-1]); + stack[top-1] = (i == EOF) ? SEXP_EOF : sexp_make_character(i); + break; case OP_RET: fprintf(stderr, "returning @ %d: ", top-1); fflush(stderr); @@ -819,6 +861,13 @@ _OP(OPC_TYPE_PREDICATE, OP_EOFP, 1, 0, 0, 0, 0, "eof-object?"), _OP(OPC_GENERIC, OP_APPLY1, 2, 0, SEXP_PROCEDURE, SEXP_PAIR, 0, "apply1"), _OP(OPC_GENERIC, OP_CALLCC, 1, SEXP_PROCEDURE, 0, 0, 0, "call-with-current-continuation"), _OP(OPC_GENERIC, OP_ERROR, 1, SEXP_STRING, 0, 0, 0, "error"), +{SEXP_OPCODE, OPC_IO, OP_WRITE, 1, 1, 0, SEXP_OPORT, 0, "write", (sexp)&cur_output_port, NULL}, +{SEXP_OPCODE, OPC_IO, OP_DISPLAY, 1, 1, 0, SEXP_OPORT, 0, "display", (sexp)&cur_output_port, NULL}, +{SEXP_OPCODE, OPC_IO, OP_WRITE_CHAR, 1, 1, 0, SEXP_OPORT, 0, "write-char", (sexp)&cur_output_port, NULL}, +{SEXP_OPCODE, OPC_IO, OP_NEWLINE, 0, 1, 0, SEXP_OPORT, 0, "newline", (sexp)&cur_output_port, NULL}, +{SEXP_OPCODE, OPC_IO, OP_FLUSH_OUTPUT, 0, 1, 0, SEXP_OPORT, 0, "flush-output", (sexp)&cur_output_port, NULL}, +{SEXP_OPCODE, OPC_IO, OP_READ, 0, 1, 0, SEXP_IPORT, 0, "read", (sexp)&cur_input_port, NULL}, +{SEXP_OPCODE, OPC_IO, OP_READ_CHAR, 0, 1, 0, SEXP_IPORT, 0, "read-char", (sexp)&cur_input_port, NULL}, _FN1(SEXP_PAIR, "reverse", sexp_reverse), _FN1(SEXP_PAIR, "list->vector", sexp_list_to_vector), _FN2(0, SEXP_PAIR, "memq", sexp_memq), diff --git a/eval.h b/eval.h index e8b9b2e3..01291820 100644 --- a/eval.h +++ b/eval.h @@ -74,6 +74,7 @@ enum opcode_classes { OPC_ARITHMETIC, OPC_ARITHMETIC_INV, OPC_ARITHMETIC_CMP, + OPC_IO, OPC_CONSTRUCTOR, OPC_ACCESSOR, OPC_PARAMETER, @@ -145,6 +146,13 @@ enum opcode_names { OP_GE, OP_EQN, OP_EQ, + OP_DISPLAY, + OP_WRITE, + OP_WRITE_CHAR, + OP_NEWLINE, + OP_FLUSH_OUTPUT, + OP_READ, + OP_READ_CHAR, }; /**************************** prototypes ******************************/ From 160149c97b317a0639c16fa45a41f56bf0c3ba56 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 9 Mar 2009 23:41:17 +0900 Subject: [PATCH 021/154] variadic args working --- eval.c | 138 ++++++++++++++++++++++++++++++++++++++------------------- eval.h | 8 ++++ sexp.c | 50 +++++++++++++-------- sexp.h | 6 ++- 4 files changed, 137 insertions(+), 65 deletions(-) diff --git a/eval.c b/eval.c index 08a122d4..4403c6f6 100644 --- a/eval.c +++ b/eval.c @@ -21,20 +21,18 @@ static sexp continuation_resumer; #endif /********************** environment utilities ***************************/ + static sexp env_cell(env e, sexp key) { - sexp ls, res=NULL; + sexp ls; do { - for (ls=e->bindings; SEXP_PAIRP(ls); ls=SEXP_CDR(ls)) { - if (SEXP_CAAR(ls) == key) { - res = SEXP_CAR(ls); - break; - } - } + for (ls=e->bindings; SEXP_PAIRP(ls); ls=SEXP_CDR(ls)) + if (SEXP_CAAR(ls) == key) + return SEXP_CAR(ls); e = e->parent; - } while (e && ! res); + } while (e); - return res; + return NULL; } static int env_global_p (env e, sexp id) { @@ -62,13 +60,23 @@ static env extend_env_closure (env e, sexp fv) { e2->tag = SEXP_ENV; e2->parent = e; e2->bindings = SEXP_NULL; - for (i=0; SEXP_PAIRP(fv); fv = SEXP_CDR(fv), i++) { + for (i=0; SEXP_PAIRP(fv); fv = SEXP_CDR(fv), i++) e2->bindings = sexp_cons(sexp_cons(SEXP_CAR(fv), sexp_make_integer(i)), e2->bindings); - } return e2; } +static sexp sexp_reverse_flatten_dot (sexp ls) { + sexp res; + for (res=SEXP_NULL; SEXP_PAIRP(ls); ls=SEXP_CDR(ls)) + res = sexp_cons(SEXP_CAR(ls), res); + return (SEXP_NULLP(ls) ? res : sexp_cons(ls, res)); +} + +static sexp sexp_flatten_dot (sexp ls) { + return sexp_nreverse(sexp_reverse_flatten_dot(ls)); +} + /************************* bytecode utilities ***************************/ static void shrink_bcode(bytecode *bc, unsigned int i) { @@ -112,13 +120,15 @@ static void emit_word(bytecode *bc, unsigned int *i, sexp_uint_t val) { #define emit_push(bc,i,obj) (emit(bc,i,OP_PUSH), emit_word(bc,i,(sexp_uint_t)obj)) -static sexp sexp_make_procedure(sexp bc, sexp vars) { - sexp proc = SEXP_NEW(); - if (! proc) return SEXP_ERROR; +static sexp sexp_make_procedure(char flags, unsigned short num_args, + sexp bc, sexp vars) { + procedure proc = SEXP_ALLOC(sizeof(struct procedure)); proc->tag = SEXP_PROCEDURE; - proc->data1 = (void*) bc; - proc->data2 = (void*) vars; - return proc; + proc->flags = flags; + proc->num_args = num_args; + proc->bc = (bytecode) bc; + proc->vars = vars; + return (sexp) proc; } /************************* the compiler ***************************/ @@ -178,14 +188,14 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, emit(bc, i, OP_JUMP); tmp2 = *i; emit(bc, i, 0); - ((signed char*) (*bc)->data)[tmp1] = (*i)-tmp1-1; /* patch */ + ((signed char*) (*bc)->data)[tmp1] = (*i)-tmp1; /* patch */ if (SEXP_PAIRP(SEXP_CDDDR(obj))) { analyze(SEXP_CADDDR(obj), bc, i, e, params, fv, sv, d); } else { emit_push(bc, i, SEXP_UNDEF); (*d)++; } - ((signed char*) (*bc)->data)[tmp2] = (*i)-tmp2-1; /* patch */ + ((signed char*) (*bc)->data)[tmp2] = (*i)-tmp2; /* patch */ break; case CORE_QUOTE: emit_push(bc, i, SEXP_CADR(obj)); @@ -205,9 +215,10 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, case OPC_CONSTRUCTOR: case OPC_ACCESSOR: case OPC_GENERIC: - if (SEXP_NULLP(SEXP_CDR(obj))) { + tmp1 = sexp_length(SEXP_CDR(obj)); + if (tmp1 == 0) { errx(1, "opcode with no arguments: %s", ((opcode)o1)->name); - } else if (SEXP_NULLP(SEXP_CDDR(obj))) { + } else if (tmp1 == 1) { if (((opcode)o1)->op_class == OPC_ARITHMETIC_INV) { analyze(SEXP_CADR(obj), bc, i, e, params, fv, sv, d); emit(bc, i, ((opcode)o1)->op_inverse); @@ -225,7 +236,11 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, analyze(SEXP_CAR(o2), bc, i, e, params, fv, sv, d); } emit(bc, i, ((opcode)o1)->op_name); - (*d) -= sexp_length(SEXP_CDDR(obj)); + (*d) -= (tmp1-1); + if (((opcode)o1)->op_class == OPC_ARITHMETIC) { + for (tmp1-=2; tmp1>0; tmp1--) + emit(bc, i, ((opcode)o1)->op_name); + } } break; case OPC_IO: @@ -384,13 +399,18 @@ sexp set_vars (env e, sexp formals, sexp obj, sexp sv) { void analyze_lambda (sexp name, sexp formals, sexp body, bytecode *bc, unsigned int *i, env e, sexp params, sexp fv, sexp sv, unsigned int *d) { - sexp obj, ls, fv2 = free_vars(e, formals, body, SEXP_NULL); - env e2 = extend_env_closure(e, formals); + sexp obj, ls, flat_formals, fv2; + env e2; int k; + flat_formals = sexp_flatten_dot(formals); + fv2 = free_vars(e, flat_formals, body, SEXP_NULL); + e2 = extend_env_closure(e, flat_formals); fprintf(stderr, "%d free-vars\n", sexp_length(fv2)); sexp_write(fv2, cur_error_port); fprintf(stderr, "\n"); - obj = (sexp) compile(formals, body, e2, fv2, sv, 0); + /* compile the body with respect to the new params */ + obj = (sexp) compile(flat_formals, body, e2, fv2, sv, 0); + /* push the closed vars */ emit_push(bc, i, SEXP_UNDEF); emit_push(bc, i, sexp_make_integer(sexp_length(fv2))); emit(bc, i, OP_MAKE_VECTOR); @@ -404,7 +424,10 @@ void analyze_lambda (sexp name, sexp formals, sexp body, emit(bc, i, OP_DROP); (*d)--; } + /* push the additional procedure info and make the closure */ emit_push(bc, i, obj); + emit_push(bc, i, sexp_make_integer(sexp_length(formals))); + emit_push(bc, i, sexp_make_integer(sexp_listp(formals) ? 0 : 1)); emit(bc, i, OP_MAKE_PROCEDURE); } @@ -412,13 +435,11 @@ bytecode compile(sexp params, sexp obj, env e, sexp fv, sexp sv, int done_p) { unsigned int i = 0, j, d = 0; bytecode bc = (bytecode) SEXP_ALLOC(sizeof(struct bytecode)+INIT_BCODE_SIZE); sexp sv2 = set_vars(e, params, obj, SEXP_NULL), ls; - /* fprintf(stderr, "set-vars: "); sexp_write(sv2, stderr); fprintf(stderr, "\n"); */ bc->tag = SEXP_BYTECODE; bc->len = INIT_BCODE_SIZE; - /* fprintf(stderr, "analyzing\n"); */ + /* box mutable vars */ for (ls=params; SEXP_PAIRP(ls); ls=SEXP_CDR(ls)) { if ((j = sexp_list_index(sv2, SEXP_CAR(ls)) >= 0)) { - /* fprintf(stderr, "consing mutable var\n"); */ emit_push(&bc, &i, SEXP_NULL); emit(&bc, &i, OP_STACK_REF); emit_word(&bc, &i, j+4); @@ -429,20 +450,19 @@ bytecode compile(sexp params, sexp obj, env e, sexp fv, sexp sv, int done_p) { } } sv = sexp_append(sv2, sv); + /* analyze body sequence */ for ( ; SEXP_PAIRP(obj); obj=SEXP_CDR(obj)) { - /* fprintf(stderr, "loop: "); sexp_write(obj, stderr); fprintf(stderr, "\n"); */ analyze(SEXP_CAR(obj), &bc, &i, e, params, fv, sv, &d); if (SEXP_PAIRP(SEXP_CDR(obj))) emit(&bc, &i, OP_DROP); } + /* return */ emit(&bc, &i, done_p ? OP_DONE : OP_RET); shrink_bcode(&bc, i); - print_bytecode(bc); + /* print_bytecode(bc); */ disasm(bc); return bc; } -/************************ library functions ***************************/ - /*********************** the virtual machine **************************/ sexp sexp_save_stack(sexp *stack, unsigned int to) { @@ -468,7 +488,7 @@ unsigned int sexp_restore_stack(sexp saved, sexp *current) { sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { unsigned char *ip=bc->data; sexp cp=SEXP_UNDEF, tmp1, tmp2; - int i; + int i, j, k; loop: switch (*ip++) { @@ -517,8 +537,8 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { top-=2; break; case OP_MAKE_PROCEDURE: - stack[top-2]=sexp_make_procedure(stack[top-1], stack[top-2]); - top--; + stack[top-4]=sexp_make_procedure((int) stack[top-1], (int) stack[top-2], stack[top-3], stack[top-4]); + top-=3; break; case OP_MAKE_VECTOR: stack[top-2]=sexp_make_vector(sexp_unbox_integer(stack[top-1]), stack[top-2]); @@ -633,10 +653,37 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { case OP_CALL: /* fprintf(stderr, "CALL\n"); */ i = (sexp_uint_t) ((sexp*)ip)[0]; + i = sexp_unbox_integer(i); tmp1 = stack[top-1]; if (! SEXP_PROCEDUREP(tmp1)) - errx(2, "non-procedure application: %p", tmp1); - stack[top-1] = (sexp) i; + sexp_raise(sexp_intern("non-procedure-application")); + j = i - sexp_unbox_integer(sexp_procedure_num_args(tmp1)); + if (j < 0) + sexp_raise(sexp_intern("not-enough-args")); + if (j > 0) { + if (sexp_procedure_variadic_p(tmp1)) { + stack[top-i-1] = sexp_cons(stack[top-i-1], SEXP_NULL); + for (k=top-i; k=top-i; k--) + stack[k] = stack[k-1]; + stack[top-i-1] = SEXP_NULL; + top++; + i++; + print_stack(stack, top); + } + stack[top-1] = sexp_make_integer(i); stack[top] = sexp_make_integer(ip+4); stack[top+1] = cp; top+=2; @@ -679,7 +726,8 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { /* fprintf(stderr, "saved: ", top); */ /* sexp_write(tmp2, cur_error_port); */ /* fprintf(stderr, "\n", top); */ - stack[top-1] = sexp_make_procedure(continuation_resumer, + stack[top-1] = sexp_make_procedure(0, (int) sexp_make_integer(1), + continuation_resumer, sexp_vector(1, tmp2)); top+=3; bc = sexp_procedure_code(tmp1); @@ -732,17 +780,17 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { top-=3; break; case OP_JUMP_UNLESS: - fprintf(stderr, "JUMP UNLESS, stack top is %d\n", stack[top-1]); + /* fprintf(stderr, "JUMP UNLESS, stack top is %d\n", stack[top-1]); */ if (stack[--top] == SEXP_FALSE) { - fprintf(stderr, "test passed, jumping to + %d => %d\n", ((signed char*)ip)[0], ip + ((signed char*)ip)[0]); + /* fprintf(stderr, "test failed, jumping to + %d => %p\n", ((signed char*)ip)[0], ip + ((signed char*)ip)[0]); */ ip += ((signed char*)ip)[0]; } else { - fprintf(stderr, "test failed, not jumping\n"); + /* fprintf(stderr, "test passed, not jumping\n"); */ ip++; } break; case OP_JUMP: - fprintf(stderr, "jumping to + %d => %d\n", ((signed char*)ip)[0], ip + ((signed char*)ip)[0]); + /* fprintf(stderr, "jumping to + %d => %p\n", ((signed char*)ip)[0], ip + ((signed char*)ip)[0]); */ ip += ((signed char*)ip)[0]; break; case OP_DISPLAY: @@ -835,8 +883,8 @@ _OP(OPC_ACCESSOR, OP_VECTOR_SET,3,0, SEXP_VECTOR, SEXP_FIXNUM, 0,"vector-set!"), _OP(OPC_ACCESSOR, OP_STRING_REF,2,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-ref"), _OP(OPC_ACCESSOR, OP_STRING_SET,3,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-set!"), _OP(OPC_ARITHMETIC, OP_ADD, 0, 1, SEXP_FIXNUM, 0, 0, "+"), -_OP(OPC_ARITHMETIC_INV, OP_SUB, 0, 1, SEXP_FIXNUM, 0, OP_NEG, "-"), _OP(OPC_ARITHMETIC, OP_MUL, 0, 1, SEXP_FIXNUM, 0, 0, "*"), +_OP(OPC_ARITHMETIC_INV, OP_SUB, 0, 1, SEXP_FIXNUM, 0, OP_NEG, "-"), _OP(OPC_ARITHMETIC_INV, OP_DIV, 0, 1, SEXP_FIXNUM, 0, OP_INV, "/"), _OP(OPC_ARITHMETIC, OP_MOD, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, 0, "%"), _OP(OPC_ARITHMETIC_CMP, OP_LT, 0, 1, SEXP_FIXNUM, 0, 0, "<"), @@ -847,7 +895,7 @@ _OP(OPC_ARITHMETIC_CMP, OP_EQN, 0, 1, SEXP_FIXNUM, 0, 0, "="), _OP(OPC_PREDICATE, OP_EQ, 2, 0, 0, 0, 0, "eq?"), _OP(OPC_CONSTRUCTOR, OP_CONS, 2, 0, 0, 0, 0, "cons"), _OP(OPC_CONSTRUCTOR, OP_MAKE_VECTOR, 2, 0, SEXP_FIXNUM, 0, 0, "make-vector"), -_OP(OPC_CONSTRUCTOR, OP_MAKE_PROCEDURE, 2, 0, 0, 0, 0, "make-procedure"), +_OP(OPC_CONSTRUCTOR, OP_MAKE_PROCEDURE, 4, 0, 0, 0, 0, "make-procedure"), _OP(OPC_TYPE_PREDICATE, OP_PAIRP, 1, 0, 0, 0, 0, "pair?"), _OP(OPC_TYPE_PREDICATE, OP_NULLP, 1, 0, 0, 0, 0, "null?"), _OP(OPC_TYPE_PREDICATE, OP_STRINGP, 1, 0, 0, 0, 0, "string?"), @@ -962,7 +1010,7 @@ int main (int argc, char **argv) { i = 0; emit_push(&bc, &i, (sexp_uint_t) SEXP_UNDEF); emit(&bc, &i, OP_DONE); - err_handler = sexp_make_procedure((sexp)bc, sexp_make_vector(0, SEXP_UNDEF)); + err_handler = sexp_make_procedure(0, 0, (sexp)bc, sexp_make_vector(0, SEXP_UNDEF)); err_handler_sym = sexp_intern("*error-handler*"); env_define(e, err_handler_sym, err_handler); exception_handler_cell = env_cell(e, err_handler_sym); diff --git a/eval.h b/eval.h index 01291820..adb492ee 100644 --- a/eval.h +++ b/eval.h @@ -29,6 +29,14 @@ typedef struct bytecode { unsigned char data[]; } *bytecode; +typedef struct procedure { + char tag; + char flags; + unsigned short num_args; + bytecode bc; + sexp vars; +} *procedure; + typedef struct env { char tag; struct env *parent; diff --git a/sexp.c b/sexp.c index 2101681d..0a33c04e 100644 --- a/sexp.c +++ b/sexp.c @@ -35,6 +35,8 @@ static char sexp_separators[] = { 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 0tag = SEXP_PAIR; pair->data1 = (void*) head; pair->data2 = (void*) tail; @@ -182,7 +183,6 @@ unsigned long sexp_length(sexp ls) { sexp sexp_make_flonum(double f) { sexp x = SEXP_NEW(); - if (! x) return SEXP_ERROR; x->tag = SEXP_FLONUM; sexp_flonum_value(x) = f; return x; @@ -190,10 +190,8 @@ sexp sexp_make_flonum(double f) { sexp sexp_make_string(char *str) { sexp s = SEXP_NEW(); - if (! s) return SEXP_ERROR; unsigned long len = strlen(str); char *mystr = SEXP_ALLOC(len+1); - if (! mystr) { SEXP_FREE(s); return SEXP_ERROR; } memcpy(mystr, str, len+1); s->tag = SEXP_STRING; s->data1 = (void*) len; @@ -255,10 +253,8 @@ sexp sexp_intern(char *str) { } sym = SEXP_NEW(); - if (! sym) { return SEXP_ERROR; } len = strlen(str); mystr = SEXP_ALLOC(len+1); - if (! mystr) { SEXP_FREE(sym); return SEXP_ERROR; } memcpy(mystr, str, len+1); mystr[len]=0; sym->tag = SEXP_SYMBOL; @@ -273,9 +269,7 @@ sexp sexp_make_vector(unsigned int len, sexp dflt) { sexp v, *x; if (! len) return the_empty_vector; v = SEXP_NEW(); - if (v == NULL) return SEXP_ERROR; x = (void*) SEXP_ALLOC(len*sizeof(sexp)); - if (x == NULL) return SEXP_ERROR; for (i=0; itag = SEXP_IPORT; p->data1 = in; return p; @@ -355,7 +345,6 @@ sexp sexp_make_input_port(FILE* in) { sexp sexp_make_output_port(FILE* out) { sexp p = SEXP_NEW(); - if (p == NULL) return SEXP_ERROR; p->tag = SEXP_OPORT; p->data1 = out; return p; @@ -547,7 +536,7 @@ 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 += ((c<='9') ? (c - '0') : ((toupper(c) - 'A') + 10))*scale; + res += digit_value(c)*scale; sexp_push_char(c, in); return sexp_make_flonum(whole + res); } @@ -564,7 +553,7 @@ sexp sexp_read_number(sexp in, int base) { } for (c=sexp_read_char(in); isxdigit(c); c=sexp_read_char(in)) - res = res * base + ((c<='9') ? (c - '0') : ((toupper(c) - 'A') + 10)); + res = res * base + digit_value(c); if (c=='.') { if (base != 10) { fprintf(stderr, "decimal found in non-base 10"); @@ -633,7 +622,7 @@ sexp sexp_read_raw (sexp in) { return SEXP_ERROR; } else { tmp = sexp_read_raw(in); - if (sexp_read(in) != SEXP_CLOSE) { + if (sexp_read_raw(in) != SEXP_CLOSE) { fprintf(stderr, "sexp: multiple tokens in dotted tail\n"); sexp_free(res); return SEXP_ERROR; @@ -681,6 +670,31 @@ sexp sexp_read_raw (sexp in) { 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 { + fprintf(stderr, "unknown character name: '%s'\n", str); + res = SEXP_ERROR; + } + } + break; case '(': sexp_push_char(c1, in); res = sexp_read(in); diff --git a/sexp.h b/sexp.h index 8d15dbe3..3a9dd2e8 100644 --- a/sexp.h +++ b/sexp.h @@ -146,8 +146,10 @@ typedef long sexp_sint_t; #define sexp_vector_ref(x, i) (sexp_vector_data(x)[sexp_unbox_integer(i)]) #define sexp_vector_set(x, i, v) (sexp_vector_data(x)[sexp_unbox_integer(i)] = (v)) -#define sexp_procedure_code(x) ((bytecode) ((sexp)x)->data1) -#define sexp_procedure_vars(x) ((sexp) ((sexp)x)->data2) +#define sexp_procedure_num_args(x) (((procedure)x)->num_args) +#define sexp_procedure_variadic_p(x) (sexp_unbox_integer(((procedure)x)->flags) & 1) +#define sexp_procedure_code(x) ((bytecode) ((procedure)x)->bc) +#define sexp_procedure_vars(x) ((sexp) ((procedure)x)->vars) #define sexp_string_length(x) ((sexp_uint_t) x->data1) #define sexp_string_data(x) ((char*) x->data2) From f63382cff87f43946620e01de3ca879e293aa1cc Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 10 Mar 2009 15:52:45 +0900 Subject: [PATCH 022/154] fixing stack depth bug in conditionals --- Makefile | 2 +- eval.c | 119 ++++++++++++++++++++++++++++++++----------------------- eval.h | 9 +++-- 3 files changed, 76 insertions(+), 54 deletions(-) diff --git a/Makefile b/Makefile index 5cd571f0..c62c1921 100644 --- a/Makefile +++ b/Makefile @@ -3,7 +3,7 @@ all: chibi-scheme -CFLAGS=-g -Os +CFLAGS=-g -fno-inline -Os GC_OBJ=./gc/gc.a diff --git a/eval.c b/eval.c index 4403c6f6..695b8641 100644 --- a/eval.c +++ b/eval.c @@ -134,22 +134,24 @@ static sexp sexp_make_procedure(char flags, unsigned short num_args, /************************* the compiler ***************************/ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, - sexp params, sexp fv, sexp sv, unsigned int *d) { - int tmp1, tmp2; + sexp params, sexp fv, sexp sv, unsigned int *d, int tailp) { + int tmp1, tmp2, tmp3; env e2 = e; sexp o1, o2, cell; if (SEXP_PAIRP(obj)) { if (SEXP_SYMBOLP(SEXP_CAR(obj))) { o1 = env_cell(e, SEXP_CAR(obj)); - if (! o1) - errx(1, "unknown operator: %s", SEXP_CAR(obj)); + if (! o1) { + analyze_app(obj, bc, i, e, params, fv, sv, d, tailp); + return; + } o1 = SEXP_CDR(o1); if (SEXP_COREP(o1)) { switch (((core_form)o1)->code) { case CORE_LAMBDA: analyze_lambda(SEXP_FALSE, SEXP_CADR(obj), SEXP_CDDR(obj), - bc, i, e, params, fv, sv, d); + bc, i, e, params, fv, sv, d, tailp); break; case CORE_DEFINE: if ((((core_form)o1)->code == CORE_DEFINE) @@ -157,9 +159,9 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, analyze_lambda(SEXP_CAR(SEXP_CADR(obj)), SEXP_CDR(SEXP_CADR(obj)), SEXP_CDDR(obj), - bc, i, e, params, fv, sv, d); + bc, i, e, params, fv, sv, d, 0); } else { - analyze(SEXP_CADDR(obj), bc, i, e, params, fv, sv, d); + analyze(SEXP_CADDR(obj), bc, i, e, params, fv, sv, d, 0); } emit(bc, i, OP_GLOBAL_SET); emit_word(bc, i, (sexp_uint_t) (SEXP_PAIRP(SEXP_CADR(obj)) @@ -169,28 +171,33 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, (*d)++; break; case CORE_SET: - analyze(SEXP_CADDR(obj), bc, i, e, params, fv, sv, d); + analyze(SEXP_CADDR(obj), bc, i, e, params, fv, sv, d, 0); analyze_var_ref(SEXP_CADR(obj), bc, i, e, params, fv, SEXP_NULL, d); emit(bc, i, OP_SET_CAR); break; case CORE_BEGIN: for (o2 = SEXP_CDR(obj); SEXP_PAIRP(o2); o2 = SEXP_CDR(o2)) { - analyze(SEXP_CAR(o2), bc, i, e, params, fv, sv, d); - if (SEXP_PAIRP(SEXP_CDR(o2))) emit(bc, i, OP_DROP); + if (SEXP_PAIRP(SEXP_CDR(o2))) { + analyze(SEXP_CAR(o2), bc, i, e, params, fv, sv, d, 0); + emit(bc, i, OP_DROP); + } else + analyze(SEXP_CAR(o2), bc, i, e, params, fv, sv, d, tailp); } break; case CORE_IF: - analyze(SEXP_CADR(obj), bc, i, e, params, fv, sv, d); + analyze(SEXP_CADR(obj), bc, i, e, params, fv, sv, d, 0); emit(bc, i, OP_JUMP_UNLESS); /* jumps if test fails */ + (*d)--; tmp1 = *i; emit(bc, i, 0); - analyze(SEXP_CADDR(obj), bc, i, e, params, fv, sv, d); + analyze(SEXP_CADDR(obj), bc, i, e, params, fv, sv, d, tailp); emit(bc, i, OP_JUMP); + (*d)--; tmp2 = *i; emit(bc, i, 0); ((signed char*) (*bc)->data)[tmp1] = (*i)-tmp1; /* patch */ if (SEXP_PAIRP(SEXP_CDDDR(obj))) { - analyze(SEXP_CADDDR(obj), bc, i, e, params, fv, sv, d); + analyze(SEXP_CADDDR(obj), bc, i, e, params, fv, sv, d, tailp); } else { emit_push(bc, i, SEXP_UNDEF); (*d)++; @@ -220,10 +227,10 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, errx(1, "opcode with no arguments: %s", ((opcode)o1)->name); } else if (tmp1 == 1) { if (((opcode)o1)->op_class == OPC_ARITHMETIC_INV) { - analyze(SEXP_CADR(obj), bc, i, e, params, fv, sv, d); + analyze(SEXP_CADR(obj), bc, i, e, params, fv, sv, d, 0); emit(bc, i, ((opcode)o1)->op_inverse); } else { - analyze(SEXP_CADR(obj), bc, i, e, params, fv, sv, d); + analyze(SEXP_CADR(obj), bc, i, e, params, fv, sv, d, 0); if (((opcode)o1)->op_class != OPC_ARITHMETIC) { emit(bc, i, ((opcode)o1)->op_name); (*d)--; @@ -233,7 +240,7 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, for (o2 = sexp_reverse(SEXP_CDR(obj)); SEXP_PAIRP(o2); o2 = SEXP_CDR(o2)) { /* fprintf(stderr, ":: arg: %d\n", SEXP_CAR(o2)); */ - analyze(SEXP_CAR(o2), bc, i, e, params, fv, sv, d); + analyze(SEXP_CAR(o2), bc, i, e, params, fv, sv, d, 0); } emit(bc, i, ((opcode)o1)->op_name); (*d) -= (tmp1-1); @@ -252,7 +259,7 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, } for (o2 = sexp_reverse(SEXP_CDR(obj)); SEXP_PAIRP(o2); o2 = SEXP_CDR(o2)) - analyze(SEXP_CAR(o2), bc, i, e, params, fv, sv, d); + analyze(SEXP_CAR(o2), bc, i, e, params, fv, sv, d, 0); emit(bc, i, ((opcode)o1)->op_name); (*d) -= (tmp1-1); break; @@ -263,7 +270,7 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, case OPC_FOREIGN: for (o2 = sexp_reverse(SEXP_CDR(obj)); SEXP_PAIRP(o2); o2 = SEXP_CDR(o2)) { - analyze(SEXP_CAR(o2), bc, i, e, params, fv, sv, d); + analyze(SEXP_CAR(o2), bc, i, e, params, fv, sv, d, 0); } emit_push(bc, i, ((opcode)o1)->data); emit(bc, i, ((opcode)o1)->op_name); @@ -274,7 +281,7 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, } } else { /* general procedure call */ - analyze_app(obj, bc, i, e, params, fv, sv, d); + analyze_app(obj, bc, i, e, params, fv, sv, d, tailp); } } else if (SEXP_PAIRP(SEXP_CAR(obj))) { o2 = env_cell(e, SEXP_CAAR(obj)); @@ -284,7 +291,7 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, /* /\* let *\/ */ /* } else { */ /* computed application */ - analyze_app(obj, bc, i, e, params, fv, sv, d); + analyze_app(obj, bc, i, e, params, fv, sv, d, tailp); /* } */ } else { errx(1, "invalid operator: %s", SEXP_CAR(obj)); @@ -307,36 +314,38 @@ void analyze_var_ref (sexp obj, bytecode *bc, unsigned int *i, env e, /* fprintf(stderr, "compiling local ref: %p => %d (d = %d)\n", obj, tmp, *d); */ emit(bc, i, OP_STACK_REF); emit_word(bc, i, tmp + *d + 4); - (*d)++; } else if ((tmp = sexp_list_index(fv, obj)) >= 0) { /* fprintf(stderr, "compiling closure ref: %p => %d\n", obj, tmp); */ emit(bc, i, OP_CLOSURE_REF); emit_word(bc, i, tmp); - (*d)++; } else { /* fprintf(stderr, "compiling global ref: %p\n", obj); */ emit(bc, i, OP_GLOBAL_REF); emit_word(bc, i, (sexp_uint_t) obj); - (*d)++; } + (*d)++; if (sexp_list_index(sv, obj) >= 0) { /* fprintf(stderr, "mutable variable, fetching CAR\n"); */ emit(bc, i, OP_CAR); } } -void analyze_app (sexp obj, bytecode *bc, unsigned int *i, - env e, sexp params, sexp fv, sexp sv, unsigned int *d) { +void analyze_app (sexp obj, bytecode *bc, unsigned int *i, env e, + sexp params, sexp fv, sexp sv, unsigned int *d, int tailp) { sexp o1; unsigned long len = sexp_length(SEXP_CDR(obj)); /* push the arguments onto the stack */ for (o1 = sexp_reverse(SEXP_CDR(obj)); SEXP_PAIRP(o1); o1 = SEXP_CDR(o1)) { - analyze(SEXP_CAR(o1), bc, i, e, params, fv, sv, d); + analyze(SEXP_CAR(o1), bc, i, e, params, fv, sv, d, 0); } /* push the operator onto the stack */ - analyze(SEXP_CAR(obj), bc, i, e, params, fv, sv, d); + analyze(SEXP_CAR(obj), bc, i, e, params, fv, sv, d, 0); + + /* maybe overwrite the current frame */ +/* if (tailp) { */ +/* } */ /* make the call */ emit(bc, i, OP_CALL); @@ -398,16 +407,17 @@ sexp set_vars (env e, sexp formals, sexp obj, sexp sv) { void analyze_lambda (sexp name, sexp formals, sexp body, bytecode *bc, unsigned int *i, env e, - sexp params, sexp fv, sexp sv, unsigned int *d) { + sexp params, sexp fv, sexp sv, unsigned int *d, + int tailp) { sexp obj, ls, flat_formals, fv2; env e2; int k; flat_formals = sexp_flatten_dot(formals); fv2 = free_vars(e, flat_formals, body, SEXP_NULL); e2 = extend_env_closure(e, flat_formals); - fprintf(stderr, "%d free-vars\n", sexp_length(fv2)); - sexp_write(fv2, cur_error_port); - fprintf(stderr, "\n"); +/* fprintf(stderr, "%d free-vars\n", sexp_length(fv2)); */ +/* sexp_write(fv2, cur_error_port); */ +/* fprintf(stderr, "\n"); */ /* compile the body with respect to the new params */ obj = (sexp) compile(flat_formals, body, e2, fv2, sv, 0); /* push the closed vars */ @@ -452,13 +462,16 @@ bytecode compile(sexp params, sexp obj, env e, sexp fv, sexp sv, int done_p) { sv = sexp_append(sv2, sv); /* analyze body sequence */ for ( ; SEXP_PAIRP(obj); obj=SEXP_CDR(obj)) { - analyze(SEXP_CAR(obj), &bc, &i, e, params, fv, sv, &d); - if (SEXP_PAIRP(SEXP_CDR(obj))) emit(&bc, &i, OP_DROP); + if (SEXP_PAIRP(SEXP_CDR(obj))) { + analyze(SEXP_CAR(obj), &bc, &i, e, params, fv, sv, &d, 0); + emit(&bc, &i, OP_DROP); + } else + analyze(SEXP_CAR(obj), &bc, &i, e, params, fv, sv, &d, 1); } /* return */ emit(&bc, &i, done_p ? OP_DONE : OP_RET); shrink_bcode(&bc, i); - /* print_bytecode(bc); */ + print_bytecode(bc); disasm(bc); return bc; } @@ -491,6 +504,7 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { int i, j, k; loop: + /* fprintf(stderr, "OP: %s (%d)\n", (*ip<=71) ? reverse_opcode_names[*ip] : "", *ip); */ switch (*ip++) { case OP_NOOP: fprintf(stderr, "noop\n"); @@ -505,7 +519,10 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { ip += sizeof(sexp); break; case OP_STACK_REF: - stack[top] = stack[top - (unsigned int) ((sexp*)ip)[0]]; +/* fprintf(stderr, "stack-ref: %d => ", (sexp_sint_t) ((sexp*)ip)[0]); */ +/* sexp_write(stack[top - (sexp_sint_t) ((sexp*)ip)[0]], cur_error_port); */ +/* fprintf(stderr, "\n"); */ + stack[top] = stack[top - (sexp_sint_t) ((sexp*)ip)[0]]; ip += sizeof(sexp); top++; break; @@ -545,6 +562,9 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { top--; break; case OP_PUSH: +/* fprintf(stderr, "pushing: "); */ +/* sexp_write(((sexp*)ip)[0], cur_error_port); */ +/* fprintf(stderr, "\n"); */ stack[top++]=((sexp*)ip)[0]; ip += sizeof(sexp); break; @@ -647,16 +667,19 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { break; case OP_EQ: case OP_EQN: - stack[top-2]=((stack[top-2] == stack[top-1]) ? SEXP_TRUE : SEXP_FALSE); + stack[top-2]=((stack[top-1] == stack[top-2]) ? SEXP_TRUE : SEXP_FALSE); top--; break; case OP_CALL: /* fprintf(stderr, "CALL\n"); */ + /* print_stack(stack, top); */ i = (sexp_uint_t) ((sexp*)ip)[0]; i = sexp_unbox_integer(i); tmp1 = stack[top-1]; - if (! SEXP_PROCEDUREP(tmp1)) + if (! SEXP_PROCEDUREP(tmp1)) { + fprintf(stderr, "error: non-procedure app\n"); sexp_raise(sexp_intern("non-procedure-application")); + } j = i - sexp_unbox_integer(sexp_procedure_num_args(tmp1)); if (j < 0) sexp_raise(sexp_intern("not-enough-args")); @@ -675,26 +698,24 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { } } else if (sexp_procedure_variadic_p(tmp1)) { /* shift stack, set extra arg to null */ - print_stack(stack, top); for (k=top; k>=top-i; k--) stack[k] = stack[k-1]; stack[top-i-1] = SEXP_NULL; top++; i++; - print_stack(stack, top); } stack[top-1] = sexp_make_integer(i); stack[top] = sexp_make_integer(ip+4); stack[top+1] = cp; top+=2; bc = sexp_procedure_code(tmp1); - /* print_bytecode(bc); */ - /* disasm(bc); */ +/* print_bytecode(bc); */ +/* disasm(bc); */ ip = bc->data; cp = sexp_procedure_vars(tmp1); - fprintf(stderr, "... calling procedure at %p\ncp: ", ip); - /* sexp_write(cp, stderr); */ - fprintf(stderr, "\n"); +/* fprintf(stderr, "... calling procedure at %p\ncp: ", ip); */ +/* /\* sexp_write(cp, stderr); *\/ */ +/* fprintf(stderr, "\n"); */ /* fprintf(stderr, "stack at %d\n", top); */ /* print_stack(stack, top); */ break; @@ -823,17 +844,17 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { stack[top-1] = (i == EOF) ? SEXP_EOF : sexp_make_character(i); break; case OP_RET: - fprintf(stderr, "returning @ %d: ", top-1); - fflush(stderr); - sexp_write(stack[top-1], cur_error_port); - fprintf(stderr, "...\n"); +/* fprintf(stderr, "returning @ %d: ", top-1); */ +/* fflush(stderr); */ +/* sexp_write(stack[top-1], cur_error_port); */ +/* fprintf(stderr, "...\n"); */ /* print_stack(stack, top); */ cp = stack[top-2]; ip = (unsigned char*) sexp_unbox_integer(stack[top-3]); i = sexp_unbox_integer(stack[top-4]); stack[top-i-4] = stack[top-1]; top = top-i-3; - fprintf(stderr, "... done returning\n"); +/* fprintf(stderr, "... done returning\n"); */ break; case OP_DONE: fprintf(stderr, "finally returning @ %d: ", top-1); diff --git a/eval.h b/eval.h index adb492ee..8ba456ce 100644 --- a/eval.h +++ b/eval.h @@ -1,6 +1,6 @@ -/* eval.h -- headers for eval library */ +/* eval.h -- headers for eval library */ /* Copyright (c) 2009 Alex Shinn. All rights reserved. */ -/* BSD-style license: http://synthcode.com/license.txt */ +/* BSD-style license: http://synthcode.com/license.txt */ #ifndef SEXP_EVAL_H #define SEXP_EVAL_H @@ -168,10 +168,11 @@ enum opcode_names { bytecode compile(sexp params, sexp obj, env e, sexp fv, sexp sv, int done_p); void analyze_app (sexp obj, bytecode *bc, unsigned int *i, - env e, sexp params, sexp fv, sexp sv, unsigned int *d); + env e, sexp params, sexp fv, sexp sv, + unsigned int *d, int tailp); void analyze_lambda (sexp name, sexp formals, sexp body, bytecode *bc, unsigned int *i, env e, - sexp params, sexp fv, sexp sv, unsigned int *d); + sexp params, sexp fv, sexp sv, unsigned int *d, int tailp); void analyze_var_ref (sexp name, bytecode *bc, unsigned int *i, env e, sexp params, sexp fv, sexp sv, unsigned int *d); From ec57daaf5fdd3aec86354f0d66eb379bc44919a1 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 10 Mar 2009 23:07:14 +0900 Subject: [PATCH 023/154] initial tail-call optimization support --- debug.c | 9 ++++++++- eval.c | 53 ++++++++++++++++++++++++++++++++++++++++++----------- eval.h | 1 + sexp.c | 4 ++-- 4 files changed, 53 insertions(+), 14 deletions(-) diff --git a/debug.c b/debug.c index 831a9834..882c64ed 100644 --- a/debug.c +++ b/debug.c @@ -3,7 +3,8 @@ /* BSD-style license: http://synthcode.com/license.txt */ static const char* reverse_opcode_names[] = - {"NOOP", "CALL", "APPLY1", "CALLCC", "RESUMECC", "ERROR", "FCALL0", "FCALL1", + {"NOOP", "TAIL-CALL", "CALL", "APPLY1", "CALLCC", "RESUMECC", "ERROR", + "FCALL0", "FCALL1", "FCALL2", "FCALL3", "FCALL4", "FCALL5", "FCALL6", "FCALL7", "FCALLN", "JUMP-UNLESS", "JUMP", "RET", "DONE", "PARAMETER", "STACK-REF", "STACK-SET", "GLOBAL-REF", "GLOBAL-SET", "CLOSURE-REF", @@ -35,10 +36,16 @@ void disasm (bytecode bc) { break; case OP_GLOBAL_REF: case OP_GLOBAL_SET: + case OP_TAIL_CALL: case OP_CALL: case OP_PUSH: sexp_write(((sexp*)ip)[0], cur_error_port); ip += sizeof(sexp); + if (opcode==OP_TAIL_CALL) { + fprintf(stderr, " "); + sexp_write(((sexp*)ip)[0], cur_error_port); + ip += sizeof(sexp); + } break; case OP_JUMP: case OP_JUMP_UNLESS: diff --git a/eval.c b/eval.c index 695b8641..6f46353c 100644 --- a/eval.c +++ b/eval.c @@ -344,12 +344,19 @@ void analyze_app (sexp obj, bytecode *bc, unsigned int *i, env e, analyze(SEXP_CAR(obj), bc, i, e, params, fv, sv, d, 0); /* maybe overwrite the current frame */ -/* if (tailp) { */ -/* } */ - - /* make the call */ - emit(bc, i, OP_CALL); - emit_word(bc, i, (sexp_uint_t) sexp_make_integer(len)); + if (tailp) { + /* args ... */ + /* i */ + /* ip */ + /* cp */ + emit(bc, i, OP_TAIL_CALL); + emit_word(bc, i, (sexp_uint_t) sexp_make_integer(sexp_length(params)+(*d))); + emit_word(bc, i, (sexp_uint_t) sexp_make_integer(len)); + } else { + /* normal call */ + emit(bc, i, OP_CALL); + emit_word(bc, i, (sexp_uint_t) sexp_make_integer(len)); + } } sexp free_vars (env e, sexp formals, sexp obj, sexp fv) { @@ -465,10 +472,10 @@ bytecode compile(sexp params, sexp obj, env e, sexp fv, sexp sv, int done_p) { if (SEXP_PAIRP(SEXP_CDR(obj))) { analyze(SEXP_CAR(obj), &bc, &i, e, params, fv, sv, &d, 0); emit(&bc, &i, OP_DROP); - } else - analyze(SEXP_CAR(obj), &bc, &i, e, params, fv, sv, &d, 1); + } else { + analyze(SEXP_CAR(obj), &bc, &i, e, params, fv, sv, &d, ! done_p); + } } - /* return */ emit(&bc, &i, done_p ? OP_DONE : OP_RET); shrink_bcode(&bc, i); print_bytecode(bc); @@ -670,11 +677,35 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { stack[top-2]=((stack[top-1] == stack[top-2]) ? SEXP_TRUE : SEXP_FALSE); top--; break; + case OP_TAIL_CALL: + j = sexp_unbox_integer(((sexp*)ip)[0]); /* current depth */ + ip += sizeof(sexp); + i = sexp_unbox_integer(((sexp*)ip)[0]); /* number of params */ + tmp1 = stack[top-1]; /* procedure to call */ +/* fprintf(stderr, "tail call: depth=%d, i=%d, top=%d\n", j, i, top); */ +/* print_stack(stack, top); */ + /* save frame info */ + stack[top] = stack[top-i-j]; + stack[top+1] = stack[top-i-j+1]; + /* copy new args into place */ + for (k=top-i-1; kdata; + cp = sexp_procedure_vars(tmp1); + break; case OP_CALL: + if (top >= INIT_STACK_SIZE) + errx(1, "out of stack space: %d", top); /* fprintf(stderr, "CALL\n"); */ /* print_stack(stack, top); */ - i = (sexp_uint_t) ((sexp*)ip)[0]; - i = sexp_unbox_integer(i); + i = sexp_unbox_integer(((sexp*)ip)[0]); tmp1 = stack[top-1]; if (! SEXP_PROCEDUREP(tmp1)) { fprintf(stderr, "error: non-procedure app\n"); diff --git a/eval.h b/eval.h index 8ba456ce..a349ff44 100644 --- a/eval.h +++ b/eval.h @@ -91,6 +91,7 @@ enum opcode_classes { enum opcode_names { OP_NOOP, + OP_TAIL_CALL, OP_CALL, OP_APPLY1, OP_CALLCC, diff --git a/sexp.c b/sexp.c index 0a33c04e..ebf3d620 100644 --- a/sexp.c +++ b/sexp.c @@ -419,7 +419,7 @@ void sexp_write (sexp obj, sexp out) { sexp_write_char('"', out); i = sexp_string_length(obj); str = sexp_string_data(obj); - /* FALLTHROUGH */ + /* ... FALLTHROUGH ... */ case SEXP_SYMBOL: if (obj->tag != SEXP_STRING) { i = sexp_symbol_length(obj); @@ -584,7 +584,7 @@ sexp sexp_read_raw (sexp in) { while ((c1 = sexp_read_char(in)) != EOF) if (c1 == '\n') break; - /* fallthrough */ + /* ... FALLTHROUGH ... */ case ' ': case '\t': case '\n': From 66b44631e4e28f6300ed5fe7be78a8a13b428954 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Wed, 11 Mar 2009 01:25:56 +0900 Subject: [PATCH 024/154] optimizing let compilation --- eval.c | 95 ++++++++++++++++++++++++++++++++++++++++++++-------------- eval.h | 2 +- 2 files changed, 73 insertions(+), 24 deletions(-) diff --git a/eval.c b/eval.c index 6f46353c..0f0200a3 100644 --- a/eval.c +++ b/eval.c @@ -54,18 +54,24 @@ static void env_define(env e, sexp key, sexp value) { } } -static env extend_env_closure (env e, sexp fv) { +static env extend_env_closure (env e, sexp fv, int offset) { int i; env e2 = (env) SEXP_ALLOC(sizeof(struct env)); e2->tag = SEXP_ENV; e2->parent = e; e2->bindings = SEXP_NULL; - for (i=0; SEXP_PAIRP(fv); fv = SEXP_CDR(fv), i++) + for (i=offset; SEXP_PAIRP(fv); fv = SEXP_CDR(fv), i--) e2->bindings = sexp_cons(sexp_cons(SEXP_CAR(fv), sexp_make_integer(i)), e2->bindings); return e2; } +static int core_code (env e, sexp sym) { + sexp cell = env_cell(e, sym); + if (! cell || ! SEXP_COREP(SEXP_CDR(cell))) return 0; + return (((core_form)SEXP_CDR(cell))->code); +} + static sexp sexp_reverse_flatten_dot (sexp ls) { sexp res; for (res=SEXP_NULL; SEXP_PAIRP(ls); ls=SEXP_CDR(ls)) @@ -136,7 +142,7 @@ static sexp sexp_make_procedure(char flags, unsigned short num_args, void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, sexp params, sexp fv, sexp sv, unsigned int *d, int tailp) { int tmp1, tmp2, tmp3; - env e2 = e; + env e2; sexp o1, o2, cell; if (SEXP_PAIRP(obj)) { @@ -156,18 +162,21 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, case CORE_DEFINE: if ((((core_form)o1)->code == CORE_DEFINE) && SEXP_PAIRP(SEXP_CADR(obj))) { + o2 = SEXP_CAR(SEXP_CADR(obj)); analyze_lambda(SEXP_CAR(SEXP_CADR(obj)), SEXP_CDR(SEXP_CADR(obj)), SEXP_CDDR(obj), bc, i, e, params, fv, sv, d, 0); } else { + o2 = SEXP_CADR(obj); analyze(SEXP_CADDR(obj), bc, i, e, params, fv, sv, d, 0); } - emit(bc, i, OP_GLOBAL_SET); - emit_word(bc, i, (sexp_uint_t) (SEXP_PAIRP(SEXP_CADR(obj)) - ? SEXP_CAR(SEXP_CADR(obj)) - : SEXP_CADR(obj))); - emit_push(bc, i, SEXP_UNDEF); + if (! e->parent) { + emit(bc, i, OP_GLOBAL_SET); + emit_word(bc, i, (sexp_uint_t) o2); + emit_push(bc, i, SEXP_UNDEF); + } else { + } (*d)++; break; case CORE_SET: @@ -285,14 +294,33 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, } } else if (SEXP_PAIRP(SEXP_CAR(obj))) { o2 = env_cell(e, SEXP_CAAR(obj)); -/* if (o2 */ -/* && SEXP_COREP(SEXP_CDR(o2)) */ -/* && (((core_form)SEXP_CDR(o2))->code == CORE_LAMBDA)) { */ -/* /\* let *\/ */ -/* } else { */ + if (o2 + && SEXP_COREP(SEXP_CDR(o2)) + && (((core_form)SEXP_CDR(o2))->code == CORE_LAMBDA) + && sexp_listp(SEXP_CADR(SEXP_CAR(obj)))) { + /* let */ + tmp1 = sexp_length(SEXP_CADR(SEXP_CAR(obj))); + e2 = extend_env_closure(e, SEXP_CADR(SEXP_CAR(obj)), (*d)); + for (o2=sexp_reverse(SEXP_CDR(obj)); SEXP_PAIRP(o2); o2=SEXP_CDR(o2)) + analyze(SEXP_CAR(o2), bc, i, e, params, fv, sv, d, 0); + params = sexp_append(SEXP_CADR(SEXP_CAR(obj)), params); + for (o2=SEXP_CDDR(SEXP_CAR(obj)); SEXP_PAIRP(o2); o2=SEXP_CDR(o2)) { + if (SEXP_PAIRP(SEXP_CDR(o2))) { + analyze(SEXP_CAR(o2), bc, i, e2, params, fv, sv, d, 0); + emit(bc, i, OP_DROP); + } else { + analyze(SEXP_CAR(o2), bc, i, e2, params, fv, sv, d, tailp); + } + } + emit(bc, i, OP_STACK_SET); + emit_word(bc, i, tmp1+1); + (*d) -= tmp1; + for (tmp1; tmp1>0; tmp1--) + emit(bc, i, OP_DROP); + } else { /* computed application */ analyze_app(obj, bc, i, e, params, fv, sv, d, tailp); -/* } */ + } } else { errx(1, "invalid operator: %s", SEXP_CAR(obj)); } @@ -307,13 +335,15 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, void analyze_var_ref (sexp obj, bytecode *bc, unsigned int *i, env e, sexp params, sexp fv, sexp sv, unsigned int *d) { int tmp; + sexp o1; /* fprintf(stderr, "symbol lookup, param length: %d sv: ", length(params)); */ /* sexp_write(sv, stderr); */ /* fprintf(stderr, "\n"); */ if ((tmp = sexp_list_index(params, obj)) >= 0) { /* fprintf(stderr, "compiling local ref: %p => %d (d = %d)\n", obj, tmp, *d); */ + o1 = env_cell(e, obj); emit(bc, i, OP_STACK_REF); - emit_word(bc, i, tmp + *d + 4); + emit_word(bc, i, *d - sexp_unbox_integer(SEXP_CDR(o1))); } else if ((tmp = sexp_list_index(fv, obj)) >= 0) { /* fprintf(stderr, "compiling closure ref: %p => %d\n", obj, tmp); */ emit(bc, i, OP_CLOSURE_REF); @@ -345,10 +375,6 @@ void analyze_app (sexp obj, bytecode *bc, unsigned int *i, env e, /* maybe overwrite the current frame */ if (tailp) { - /* args ... */ - /* i */ - /* ip */ - /* cp */ emit(bc, i, OP_TAIL_CALL); emit_word(bc, i, (sexp_uint_t) sexp_make_integer(sexp_length(params)+(*d))); emit_word(bc, i, (sexp_uint_t) sexp_make_integer(len)); @@ -421,7 +447,7 @@ void analyze_lambda (sexp name, sexp formals, sexp body, int k; flat_formals = sexp_flatten_dot(formals); fv2 = free_vars(e, flat_formals, body, SEXP_NULL); - e2 = extend_env_closure(e, flat_formals); + e2 = extend_env_closure(e, flat_formals, -4); /* fprintf(stderr, "%d free-vars\n", sexp_length(fv2)); */ /* sexp_write(fv2, cur_error_port); */ /* fprintf(stderr, "\n"); */ @@ -449,9 +475,9 @@ void analyze_lambda (sexp name, sexp formals, sexp body, } bytecode compile(sexp params, sexp obj, env e, sexp fv, sexp sv, int done_p) { - unsigned int i = 0, j, d = 0; + unsigned int i = 0, j, d = 0, define_ok=1; bytecode bc = (bytecode) SEXP_ALLOC(sizeof(struct bytecode)+INIT_BCODE_SIZE); - sexp sv2 = set_vars(e, params, obj, SEXP_NULL), ls; + sexp sv2 = set_vars(e, params, obj, SEXP_NULL), internals=SEXP_NULL, ls; bc->tag = SEXP_BYTECODE; bc->len = INIT_BCODE_SIZE; /* box mutable vars */ @@ -467,6 +493,28 @@ bytecode compile(sexp params, sexp obj, env e, sexp fv, sexp sv, int done_p) { } } sv = sexp_append(sv2, sv); + /* determine internal defines */ +/* for (ls=SEXP_NULL; SEXP_PAIRP(obj); obj=SEXP_CDR(obj)) { */ +/* core = SEXP_PAIRP(SEXP_CAR(obj)) && SEXP_SYMBOLP(SEXP_CAAR(obj)) */ +/* && core_code(SEXP_CAAR(obj)); */ +/* if (core == CORE_BEGIN) { */ +/* obj = sexp_cons(SEXP_CAR(obj), */ +/* sexp_append(SEXP_CDAR(obj), SEXP_CDR(obj))); */ +/* } else { */ +/* if (core == CORE_DEFINE) { */ +/* if (! define_ok) */ +/* errx(1, "definition in non-definition context: %p", obj); */ +/* internals = sexp_cons(SEXP_CADR(obj), internals); */ +/* } else { */ +/* define_ok = 0; */ +/* } */ +/* ls = sexp_cons(SEXP_CAR(obj), ls); */ +/* } */ +/* } */ +/* obj = sexp_reverse(ls); */ +/* if (SEXP_PAIRP(internals)) { */ +/* e = extend_env_closure(e, internals); */ +/* } */ /* analyze body sequence */ for ( ; SEXP_PAIRP(obj); obj=SEXP_CDR(obj)) { if (SEXP_PAIRP(SEXP_CDR(obj))) { @@ -693,7 +741,8 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { /* restore frame info */ stack[top-j-i] = stack[top]; stack[top-j-i+1] = stack[top+1]; - top -= (j-i); + top -= (j-i-1); + stack[top-1] = tmp1; /* print_stack(stack, top); */ /* exit(0); */ bc = sexp_procedure_code(tmp1); diff --git a/eval.h b/eval.h index a349ff44..9a78221a 100644 --- a/eval.h +++ b/eval.h @@ -64,7 +64,7 @@ typedef struct core_form { } *core_form; enum core_form_names { - CORE_DEFINE, + CORE_DEFINE = 1, CORE_SET, CORE_LAMBDA, CORE_IF, From c2103148cb2853dc1aa1a31663e2cbfc14afe889 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Wed, 11 Mar 2009 02:53:05 +0900 Subject: [PATCH 025/154] internal define support --- eval.c | 93 ++++++++++++++++++++++++++++++++++++++++++---------------- eval.h | 2 +- sexp.h | 7 +++++ 3 files changed, 75 insertions(+), 27 deletions(-) diff --git a/eval.c b/eval.c index 0f0200a3..4414274b 100644 --- a/eval.c +++ b/eval.c @@ -176,6 +176,11 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, emit_word(bc, i, (sexp_uint_t) o2); emit_push(bc, i, SEXP_UNDEF); } else { + o1 = env_cell(e, o2); + if (! o1) + errx(1, "define in bad position: %p", o2); + emit(bc, i, OP_STACK_SET); + emit_word(bc, i, sexp_unbox_integer(SEXP_CDR(o1))); } (*d)++; break; @@ -347,7 +352,7 @@ void analyze_var_ref (sexp obj, bytecode *bc, unsigned int *i, env e, } else if ((tmp = sexp_list_index(fv, obj)) >= 0) { /* fprintf(stderr, "compiling closure ref: %p => %d\n", obj, tmp); */ emit(bc, i, OP_CLOSURE_REF); - emit_word(bc, i, tmp); + emit_word(bc, i, (sexp_uint_t) sexp_make_integer(tmp)); } else { /* fprintf(stderr, "compiling global ref: %p\n", obj); */ emit(bc, i, OP_GLOBAL_REF); @@ -475,7 +480,7 @@ void analyze_lambda (sexp name, sexp formals, sexp body, } bytecode compile(sexp params, sexp obj, env e, sexp fv, sexp sv, int done_p) { - unsigned int i = 0, j, d = 0, define_ok=1; + unsigned int i = 0, j, d = 0, core, define_ok=1; bytecode bc = (bytecode) SEXP_ALLOC(sizeof(struct bytecode)+INIT_BCODE_SIZE); sexp sv2 = set_vars(e, params, obj, SEXP_NULL), internals=SEXP_NULL, ls; bc->tag = SEXP_BYTECODE; @@ -494,36 +499,55 @@ bytecode compile(sexp params, sexp obj, env e, sexp fv, sexp sv, int done_p) { } sv = sexp_append(sv2, sv); /* determine internal defines */ -/* for (ls=SEXP_NULL; SEXP_PAIRP(obj); obj=SEXP_CDR(obj)) { */ -/* core = SEXP_PAIRP(SEXP_CAR(obj)) && SEXP_SYMBOLP(SEXP_CAAR(obj)) */ -/* && core_code(SEXP_CAAR(obj)); */ -/* if (core == CORE_BEGIN) { */ -/* obj = sexp_cons(SEXP_CAR(obj), */ -/* sexp_append(SEXP_CDAR(obj), SEXP_CDR(obj))); */ -/* } else { */ -/* if (core == CORE_DEFINE) { */ -/* if (! define_ok) */ -/* errx(1, "definition in non-definition context: %p", obj); */ -/* internals = sexp_cons(SEXP_CADR(obj), internals); */ -/* } else { */ -/* define_ok = 0; */ -/* } */ -/* ls = sexp_cons(SEXP_CAR(obj), ls); */ -/* } */ -/* } */ -/* obj = sexp_reverse(ls); */ -/* if (SEXP_PAIRP(internals)) { */ -/* e = extend_env_closure(e, internals); */ -/* } */ + if (e->parent) { + for (ls=SEXP_NULL; SEXP_PAIRP(obj); obj=SEXP_CDR(obj)) { + core = SEXP_PAIRP(SEXP_CAR(obj)) && SEXP_SYMBOLP(SEXP_CAAR(obj)) + && core_code(e, SEXP_CAAR(obj)); + if (core == CORE_BEGIN) { + obj = sexp_cons(SEXP_CAR(obj), + sexp_append(SEXP_CDAR(obj), SEXP_CDR(obj))); + } else { + if (core == CORE_DEFINE) { + if (! define_ok) + errx(1, "definition in non-definition context: %p", obj); + internals = sexp_cons(SEXP_PAIRP(SEXP_CADAR(obj)) + ? SEXP_CAR(SEXP_CADAR(obj)) : SEXP_CADAR(obj), + internals); + } else { + define_ok = 0; + } + ls = sexp_cons(SEXP_CAR(obj), ls); + } + } + obj = sexp_reverse(ls); +/* sexp_write_string("internals: ", cur_error_port); */ +/* sexp_write(internals, cur_error_port); */ +/* sexp_write_string("\n", cur_error_port); */ + j = sexp_length(internals); + if (SEXP_PAIRP(internals)) { + e = extend_env_closure(e, internals, 2); + params = sexp_append(internals, params); + for (ls=internals; SEXP_PAIRP(ls); ls=SEXP_CDR(ls)) + emit_push(&bc, &i, (sexp_uint_t) SEXP_UNDEF); + d+=j; + } + } /* analyze body sequence */ for ( ; SEXP_PAIRP(obj); obj=SEXP_CDR(obj)) { if (SEXP_PAIRP(SEXP_CDR(obj))) { analyze(SEXP_CAR(obj), &bc, &i, e, params, fv, sv, &d, 0); emit(&bc, &i, OP_DROP); } else { - analyze(SEXP_CAR(obj), &bc, &i, e, params, fv, sv, &d, ! done_p); + analyze(SEXP_CAR(obj), &bc, &i, e, params, fv, sv, &d, + ! done_p && ! SEXP_PAIRP(internals)); } } + if (SEXP_PAIRP(internals)) { + emit(&bc, &i, OP_STACK_SET); + emit_word(&bc, &i, j+1); + for (j; j>0; j--) + emit(&bc, &i, OP_DROP); + } emit(&bc, &i, done_p ? OP_DONE : OP_RET); shrink_bcode(&bc, i); print_bytecode(bc); @@ -559,7 +583,7 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { int i, j, k; loop: - /* fprintf(stderr, "OP: %s (%d)\n", (*ip<=71) ? reverse_opcode_names[*ip] : "", *ip); */ +/* fprintf(stderr, "OP: %s (%d)\n", (*ip<=71) ? reverse_opcode_names[*ip] : "", *ip); */ switch (*ip++) { case OP_NOOP: fprintf(stderr, "noop\n"); @@ -582,12 +606,20 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { top++; break; case OP_STACK_SET: +/* print_stack(stack, top); */ +/* fprintf(stderr, "stack-set: %d => ", (sexp_sint_t) ((sexp*)ip)[0]); */ +/* sexp_write(stack[top-1], cur_error_port); */ +/* fprintf(stderr, "\n"); */ stack[top - (sexp_sint_t) ((sexp*)ip)[0]] = stack[top-1]; stack[top-1] = SEXP_UNDEF; +/* print_stack(stack, top); */ ip += sizeof(sexp); break; case OP_CLOSURE_REF: - stack[top++]=sexp_vector_ref(cp,((sexp*)ip)[0]); +/* fprintf(stderr, "closure-ref: %d => ", sexp_unbox_integer(((sexp*)ip)[0])); */ +/* sexp_write(sexp_vector_ref(cp, ((sexp*)ip)[0]), cur_error_port); */ +/* fprintf(stderr, "\n"); */ + stack[top++]=sexp_vector_ref(cp, ((sexp*)ip)[0]); ip += sizeof(sexp); break; case OP_VECTOR_REF: @@ -597,6 +629,9 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { case OP_VECTOR_SET: sexp_vector_set(stack[top-1], stack[top-2], stack[top-3]); stack[top-3]=SEXP_UNDEF; +/* fprintf(stderr, "vector-set: %d => ", sexp_unbox_integer(stack[top-2])); */ +/* sexp_write(stack[top-1], cur_error_port); */ +/* fprintf(stderr, "\n"); */ top-=2; break; case OP_STRING_REF: @@ -745,6 +780,9 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { stack[top-1] = tmp1; /* print_stack(stack, top); */ /* exit(0); */ +/* sexp_debug("call proc: ", tmp1); */ +/* sexp_debug("bc: ", sexp_procedure_code(tmp1)); */ +/* fprintf(stderr, "data: %p\n", sexp_procedure_code(tmp1)->data); */ bc = sexp_procedure_code(tmp1); ip = bc->data; cp = sexp_procedure_vars(tmp1); @@ -788,6 +826,9 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { stack[top] = sexp_make_integer(ip+4); stack[top+1] = cp; top+=2; +/* sexp_debug("call proc: ", tmp1); */ +/* sexp_debug("bc: ", sexp_procedure_code(tmp1)); */ +/* fprintf(stderr, "data: %p\n", sexp_procedure_code(tmp1)->data); */ bc = sexp_procedure_code(tmp1); /* print_bytecode(bc); */ /* disasm(bc); */ diff --git a/eval.h b/eval.h index 9a78221a..658ceecf 100644 --- a/eval.h +++ b/eval.h @@ -76,7 +76,7 @@ enum core_form_names { }; enum opcode_classes { - OPC_GENERIC, + OPC_GENERIC = 1, OPC_TYPE_PREDICATE, OPC_PREDICATE, OPC_ARITHMETIC, diff --git a/sexp.h b/sexp.h index 3a9dd2e8..e889b98b 100644 --- a/sexp.h +++ b/sexp.h @@ -204,8 +204,15 @@ void sexp_printf(sexp port, sexp fmt, ...); #define SEXP_CDAR(x) (SEXP_CDR(SEXP_CAR(x))) #define SEXP_CDDR(x) (SEXP_CDR(SEXP_CDR(x))) +#define SEXP_CAAAR(x) (SEXP_CAR(SEXP_CAAR(x))) +#define SEXP_CAADR(x) (SEXP_CAR(SEXP_CADR(x))) +#define SEXP_CADAR(x) (SEXP_CAR(SEXP_CDAR(x))) #define SEXP_CADDR(x) (SEXP_CAR(SEXP_CDDR(x))) +#define SEXP_CDAAR(x) (SEXP_CDR(SEXP_CAAR(x))) +#define SEXP_CDADR(x) (SEXP_CDR(SEXP_CADR(x))) +#define SEXP_CDDAR(x) (SEXP_CDR(SEXP_CDAR(x))) #define SEXP_CDDDR(x) (SEXP_CDR(SEXP_CDDR(x))) + #define SEXP_CADDDR(x) (SEXP_CADR(SEXP_CDDR(x))) #define SEXP_CDDDDR(x) (SEXP_CDDR(SEXP_CDDR(x))) From dfc38557b9346abeb6bcc2ebe87a5a13a8067f9b Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Wed, 11 Mar 2009 15:48:18 +0900 Subject: [PATCH 026/154] initial macro support --- eval.c | 48 +++++++++++++++++++++++++++++++++++++++++++++++- eval.h | 6 ++++++ sexp.c | 6 ++++++ sexp.h | 2 ++ 4 files changed, 61 insertions(+), 1 deletion(-) diff --git a/eval.c b/eval.c index 4414274b..142ffe1a 100644 --- a/eval.c +++ b/eval.c @@ -137,14 +137,48 @@ static sexp sexp_make_procedure(char flags, unsigned short num_args, return (sexp) proc; } +static sexp sexp_make_macro (procedure p, env e) { + macro mac = SEXP_ALLOC(sizeof(struct macro)); + mac->tag = SEXP_MACRO; + mac->e = e; + mac->proc = p; + return (sexp) mac; +} + /************************* the compiler ***************************/ +sexp sexp_expand_macro (macro mac, sexp form, env e) { + sexp res, *stack = SEXP_ALLOC(sizeof(sexp)*INIT_STACK_SIZE); + bytecode bc; + unsigned int i; + fprintf(stderr, "expanding: "); + sexp_write(form, cur_error_port); + fprintf(stderr, "\n => "); + bc = (bytecode) SEXP_ALLOC(sizeof(struct bytecode)+32); + bc->tag = SEXP_BYTECODE; + bc->len = 32; + emit_push(&bc, &i, mac->e); + emit_push(&bc, &i, e); + emit_push(&bc, &i, form); + emit_push(&bc, &i, mac->proc); + emit(&bc, &i, OP_CALL); + emit_word(&bc, &i, (sexp_uint_t) sexp_make_integer(3)); + emit(&bc, &i, OP_DONE); + res = vm(bc, e, stack, 0); + sexp_write(res, cur_error_port); + fprintf(stderr, "\n"); + SEXP_FREE(bc); + SEXP_FREE(stack); + return res; +} + void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, sexp params, sexp fv, sexp sv, unsigned int *d, int tailp) { int tmp1, tmp2, tmp3; env e2; sexp o1, o2, cell; + loop: if (SEXP_PAIRP(obj)) { if (SEXP_SYMBOLP(SEXP_CAR(obj))) { o1 = env_cell(e, SEXP_CAR(obj)); @@ -159,6 +193,10 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, analyze_lambda(SEXP_FALSE, SEXP_CADR(obj), SEXP_CDDR(obj), bc, i, e, params, fv, sv, d, tailp); break; + case CORE_DEFINE_SYNTAX: + env_define(e, SEXP_CADR(obj), + sexp_make_macro((procedure) eval(SEXP_CADDR(obj), e), e)); + break; case CORE_DEFINE: if ((((core_form)o1)->code == CORE_DEFINE) && SEXP_PAIRP(SEXP_CADR(obj))) { @@ -293,6 +331,9 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, default: errx(1, "unknown opcode class: %d", ((opcode)o1)->op_class); } + } else if (SEXP_MACROP(o1)) { + obj = sexp_expand_macro((macro) o1, obj, e); + goto loop; } else { /* general procedure call */ analyze_app(obj, bc, i, e, params, fv, sv, d, tailp); @@ -575,7 +616,7 @@ unsigned int sexp_restore_stack(sexp saved, sexp *current) { return len; } -#define sexp_raise(exn) {stack[top-1]=(exn); goto call_error_handler;} +#define sexp_raise(exn) {stack[top++]=(exn); goto call_error_handler;} sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { unsigned char *ip=bc->data; @@ -590,6 +631,8 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { break; case OP_GLOBAL_REF: tmp1 = env_cell(e, ((sexp*)ip)[0]); + if (! tmp1) + sexp_raise(sexp_intern("undefined-variable")); stack[top++]=SEXP_CDR(tmp1); ip += sizeof(sexp); break; @@ -893,6 +936,7 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { break; case OP_ERROR: call_error_handler: + fprintf(stderr, "in error handler\n"); sexp_write_string("ERROR: ", cur_error_port); sexp_write(stack[top-1], cur_error_port); sexp_write_string("\n", cur_error_port); @@ -970,6 +1014,8 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { /* sexp_write(stack[top-1], cur_error_port); */ /* fprintf(stderr, "...\n"); */ /* print_stack(stack, top); */ + if (top<4) + goto end_loop; cp = stack[top-2]; ip = (unsigned char*) sexp_unbox_integer(stack[top-3]); i = sexp_unbox_integer(stack[top-4]); diff --git a/eval.h b/eval.h index 658ceecf..a32aa26e 100644 --- a/eval.h +++ b/eval.h @@ -43,6 +43,12 @@ typedef struct env { sexp bindings; } *env; +typedef struct macro { + char tag; + procedure proc; + env e; +} *macro; + typedef struct opcode { char tag; char op_class; diff --git a/sexp.c b/sexp.c index ebf3d620..f20d4607 100644 --- a/sexp.c +++ b/sexp.c @@ -411,10 +411,16 @@ void sexp_write (sexp obj, sexp out) { sexp_write_string("#", out); break; case SEXP_OPORT: sexp_write_string("#", out); break; + case SEXP_CORE: + sexp_write_string("#", out); break; + case SEXP_OPCODE: + sexp_write_string("#", out); break; case SEXP_BYTECODE: sexp_write_string("#", out); break; case SEXP_ENV: sexp_write_string("#", out); break; + case SEXP_MACRO: + sexp_write_string("#", out); break; case SEXP_STRING: sexp_write_char('"', out); i = sexp_string_length(obj); diff --git a/sexp.h b/sexp.h index e889b98b..199be5c8 100644 --- a/sexp.h +++ b/sexp.h @@ -80,6 +80,7 @@ enum sexp_types { /* the following are used only by the evaluator */ SEXP_EXCEPTION, SEXP_PROCEDURE, + SEXP_MACRO, SEXP_ENV, SEXP_BYTECODE, SEXP_CORE, @@ -124,6 +125,7 @@ typedef long sexp_sint_t; #define SEXP_BYTECODEP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag ==SEXP_BYTECODE) #define SEXP_COREP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_CORE) #define SEXP_OPCODEP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_OPCODE) +#define SEXP_MACROP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_MACRO) #define SEXP_SYMBOLP(x) (SEXP_ISYMBOLP(x) || SEXP_LSYMBOLP(x)) From 13a161e797176acda0d97dbfc4f152e62409c633 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Wed, 11 Mar 2009 18:23:49 +0900 Subject: [PATCH 027/154] 1st class opcode support --- debug.c | 2 +- eval.c | 188 +++++++++++++++++++++++++++++++++----------------------- eval.h | 11 ++-- 3 files changed, 117 insertions(+), 84 deletions(-) diff --git a/debug.c b/debug.c index 882c64ed..9871030e 100644 --- a/debug.c +++ b/debug.c @@ -5,7 +5,7 @@ static const char* reverse_opcode_names[] = {"NOOP", "TAIL-CALL", "CALL", "APPLY1", "CALLCC", "RESUMECC", "ERROR", "FCALL0", "FCALL1", - "FCALL2", "FCALL3", "FCALL4", "FCALL5", "FCALL6", "FCALL7", "FCALLN", + "FCALL2", "FCALL3", /* "FCALL4", "FCALL5", "FCALL6", "FCALL7", */ "FCALLN", "JUMP-UNLESS", "JUMP", "RET", "DONE", "PARAMETER", "STACK-REF", "STACK-SET", "GLOBAL-REF", "GLOBAL-SET", "CLOSURE-REF", "VECTOR-REF", "VECTOR-SET", "STRING-REF", "STRING-SET", "MAKE-PROCEDURE", diff --git a/eval.c b/eval.c index 142ffe1a..70ce94d5 100644 --- a/eval.c +++ b/eval.c @@ -264,73 +264,7 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, errx(1, "unknown core form: %s", ((core_form)o1)->code); } } else if (SEXP_OPCODEP(o1)) { - /* verify arity */ - switch (((opcode)o1)->op_class) { - case OPC_TYPE_PREDICATE: - case OPC_PREDICATE: - case OPC_ARITHMETIC: - case OPC_ARITHMETIC_INV: - case OPC_ARITHMETIC_CMP: - case OPC_CONSTRUCTOR: - case OPC_ACCESSOR: - case OPC_GENERIC: - tmp1 = sexp_length(SEXP_CDR(obj)); - if (tmp1 == 0) { - errx(1, "opcode with no arguments: %s", ((opcode)o1)->name); - } else if (tmp1 == 1) { - if (((opcode)o1)->op_class == OPC_ARITHMETIC_INV) { - analyze(SEXP_CADR(obj), bc, i, e, params, fv, sv, d, 0); - emit(bc, i, ((opcode)o1)->op_inverse); - } else { - analyze(SEXP_CADR(obj), bc, i, e, params, fv, sv, d, 0); - if (((opcode)o1)->op_class != OPC_ARITHMETIC) { - emit(bc, i, ((opcode)o1)->op_name); - (*d)--; - } - } - } else { - for (o2 = sexp_reverse(SEXP_CDR(obj)); SEXP_PAIRP(o2); - o2 = SEXP_CDR(o2)) { - /* fprintf(stderr, ":: arg: %d\n", SEXP_CAR(o2)); */ - analyze(SEXP_CAR(o2), bc, i, e, params, fv, sv, d, 0); - } - emit(bc, i, ((opcode)o1)->op_name); - (*d) -= (tmp1-1); - if (((opcode)o1)->op_class == OPC_ARITHMETIC) { - for (tmp1-=2; tmp1>0; tmp1--) - emit(bc, i, ((opcode)o1)->op_name); - } - } - break; - case OPC_IO: - tmp1 = sexp_length(SEXP_CDR(obj)); - if (tmp1 == ((opcode)o1)->num_args && ((opcode)o1)->var_args_p) { - emit(bc, i, OP_PARAMETER); - emit_word(bc, i, (sexp_uint_t) ((opcode)o1)->data); - (*d)++; - } - for (o2 = sexp_reverse(SEXP_CDR(obj)); SEXP_PAIRP(o2); - o2 = SEXP_CDR(o2)) - analyze(SEXP_CAR(o2), bc, i, e, params, fv, sv, d, 0); - emit(bc, i, ((opcode)o1)->op_name); - (*d) -= (tmp1-1); - break; - case OPC_PARAMETER: - emit(bc, i, ((opcode)o1)->op_name); - emit_word(bc, i, (sexp_uint_t) ((opcode)o1)->data); - break; - case OPC_FOREIGN: - for (o2 = sexp_reverse(SEXP_CDR(obj)); SEXP_PAIRP(o2); - o2 = SEXP_CDR(o2)) { - analyze(SEXP_CAR(o2), bc, i, e, params, fv, sv, d, 0); - } - emit_push(bc, i, ((opcode)o1)->data); - emit(bc, i, ((opcode)o1)->op_name); - (*d) -= sexp_length(SEXP_CDR(obj)); - break; - default: - errx(1, "unknown opcode class: %d", ((opcode)o1)->op_class); - } + analyze_opcode((opcode)o1, obj, bc, i, e, params, fv, sv, d, tailp); } else if (SEXP_MACROP(o1)) { obj = sexp_expand_macro((macro) o1, obj, e); goto loop; @@ -378,6 +312,78 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, } } +void analyze_opcode (opcode op, sexp obj, bytecode *bc, unsigned int *i, env e, + sexp params, sexp fv, sexp sv, unsigned int *d, int tailp) +{ + int tmp1; + sexp o1; + + switch (op->op_class) { + case OPC_TYPE_PREDICATE: + case OPC_PREDICATE: + case OPC_ARITHMETIC: + case OPC_ARITHMETIC_INV: + case OPC_ARITHMETIC_CMP: + case OPC_CONSTRUCTOR: + case OPC_ACCESSOR: + case OPC_GENERIC: + tmp1 = sexp_length(SEXP_CDR(obj)); + if (tmp1 == 0) { + errx(1, "opcode with no arguments: %s", op->name); + } else if (tmp1 == 1) { + if (op->op_class == OPC_ARITHMETIC_INV) { + analyze(SEXP_CADR(obj), bc, i, e, params, fv, sv, d, 0); + emit(bc, i, op->op_inverse); + } else { + analyze(SEXP_CADR(obj), bc, i, e, params, fv, sv, d, 0); + if (op->op_class != OPC_ARITHMETIC) { + emit(bc, i, op->op_name); + (*d)--; + } + } + } else { + for (o1 = sexp_reverse(SEXP_CDR(obj)); SEXP_PAIRP(o1); + o1 = SEXP_CDR(o1)) { + analyze(SEXP_CAR(o1), bc, i, e, params, fv, sv, d, 0); + } + emit(bc, i, op->op_name); + (*d) -= (tmp1-1); + if (op->op_class == OPC_ARITHMETIC) { + for (tmp1-=2; tmp1>0; tmp1--) + emit(bc, i, op->op_name); + } + } + break; + case OPC_IO: + tmp1 = sexp_length(SEXP_CDR(obj)); + if (tmp1 == op->num_args && op->var_args_p) { + emit(bc, i, OP_PARAMETER); + emit_word(bc, i, (sexp_uint_t) op->data); + (*d)++; + } + for (o1 = sexp_reverse(SEXP_CDR(obj)); SEXP_PAIRP(o1); + o1 = SEXP_CDR(o1)) + analyze(SEXP_CAR(o1), bc, i, e, params, fv, sv, d, 0); + emit(bc, i, op->op_name); + (*d) -= (tmp1-1); + break; + case OPC_PARAMETER: + emit(bc, i, op->op_name); + emit_word(bc, i, (sexp_uint_t) op->data); + break; + case OPC_FOREIGN: + for (o1=sexp_reverse(SEXP_CDR(obj)); SEXP_PAIRP(o1); o1=SEXP_CDR(o1)) { + analyze(SEXP_CAR(o1), bc, i, e, params, fv, sv, d, 0); + } + emit_push(bc, i, op->data); + emit(bc, i, op->op_name); + (*d) -= sexp_length(SEXP_CDR(obj)); + break; + default: + errx(1, "unknown opcode class: %d", op->op_class); + } +} + void analyze_var_ref (sexp obj, bytecode *bc, unsigned int *i, env e, sexp params, sexp fv, sexp sv, unsigned int *d) { int tmp; @@ -520,6 +526,32 @@ void analyze_lambda (sexp name, sexp formals, sexp body, emit(bc, i, OP_MAKE_PROCEDURE); } +sexp make_param_list(sexp_uint_t i) { + sexp res = SEXP_NULL; + char sym[2]="a"; + for (sym[0]+=i; i>0; i--) { + sym[0] = sym[0]-1; + res = sexp_cons(sexp_intern(sym), res); + } + return res; +} + +sexp make_opcode_procedure(opcode op, sexp_uint_t i, env e) { + bytecode bc = (bytecode) SEXP_ALLOC(sizeof(struct bytecode)+INIT_BCODE_SIZE); + sexp params = make_param_list(i); + unsigned int pos=0, d=0; + e = extend_env_closure(e, params, -4); + bc->tag = SEXP_BYTECODE; + bc->len = INIT_BCODE_SIZE; + analyze_opcode(op, sexp_cons((sexp) op, params), &bc, &pos, e, params, + SEXP_NULL, SEXP_NULL, &d, 0); + emit(&bc, &pos, OP_RET); + shrink_bcode(&bc, pos); + /* disasm(bc); */ + return sexp_make_procedure(0, (int) sexp_make_integer(i), + (sexp) bc, SEXP_UNDEF); +} + bytecode compile(sexp params, sexp obj, env e, sexp fv, sexp sv, int done_p) { unsigned int i = 0, j, d = 0, core, define_ok=1; bytecode bc = (bytecode) SEXP_ALLOC(sizeof(struct bytecode)+INIT_BCODE_SIZE); @@ -644,6 +676,7 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { /* fprintf(stderr, "stack-ref: %d => ", (sexp_sint_t) ((sexp*)ip)[0]); */ /* sexp_write(stack[top - (sexp_sint_t) ((sexp*)ip)[0]], cur_error_port); */ /* fprintf(stderr, "\n"); */ +/* print_stack(stack, top); */ stack[top] = stack[top - (sexp_sint_t) ((sexp*)ip)[0]]; ip += sizeof(sexp); top++; @@ -837,6 +870,11 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { /* print_stack(stack, top); */ i = sexp_unbox_integer(((sexp*)ip)[0]); tmp1 = stack[top-1]; + make_call: + if (SEXP_OPCODEP(tmp1)) + /* hack, compile an opcode application on the fly */ + tmp1 = make_opcode_procedure((opcode) tmp1, i, e); + print_stack(stack, top); if (! SEXP_PROCEDUREP(tmp1)) { fprintf(stderr, "error: non-procedure app\n"); sexp_raise(sexp_intern("non-procedure-application")); @@ -866,7 +904,7 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { i++; } stack[top-1] = sexp_make_integer(i); - stack[top] = sexp_make_integer(ip+4); + stack[top] = sexp_make_integer(ip+sizeof(sexp)); stack[top+1] = cp; top+=2; /* sexp_debug("call proc: ", tmp1); */ @@ -884,22 +922,16 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { /* print_stack(stack, top); */ break; case OP_APPLY1: + print_stack(stack, top); tmp1 = stack[top-1]; - if (! SEXP_PROCEDUREP(tmp1)) - errx(2, "non-procedure application: %p", tmp1); tmp2 = stack[top-2]; i = sexp_length(tmp2); top += (i-2); for ( ; SEXP_PAIRP(tmp2); tmp2=SEXP_CDR(tmp2), top--) stack[top-1] = SEXP_CAR(tmp2); - top += i+3; - stack[top-3] = sexp_make_integer(i); - stack[top-2] = sexp_make_integer(ip); - stack[top-1] = cp; - bc = sexp_procedure_code(tmp1); - ip = bc->data; - cp = sexp_procedure_vars(tmp1); - break; + top += i+1; + ip -= sizeof(sexp); + goto make_call; case OP_CALLCC: tmp1 = stack[top-1]; if (! SEXP_PROCEDUREP(tmp1)) diff --git a/eval.h b/eval.h index a32aa26e..766d2784 100644 --- a/eval.h +++ b/eval.h @@ -107,10 +107,10 @@ enum opcode_names { OP_FCALL1, OP_FCALL2, OP_FCALL3, - OP_FCALL4, - OP_FCALL5, - OP_FCALL6, - OP_FCALL7, +/* OP_FCALL4, */ +/* OP_FCALL5, */ +/* OP_FCALL6, */ +/* OP_FCALL7, */ OP_FCALLN, OP_JUMP_UNLESS, OP_JUMP, @@ -182,7 +182,8 @@ void analyze_lambda (sexp name, sexp formals, sexp body, sexp params, sexp fv, sexp sv, unsigned int *d, int tailp); void analyze_var_ref (sexp name, bytecode *bc, unsigned int *i, env e, sexp params, sexp fv, sexp sv, unsigned int *d); - +void analyze_opcode (opcode op, sexp obj, bytecode *bc, unsigned int *i, env e, + sexp params, sexp fv, sexp sv, unsigned int *d, int tailp); sexp vm(bytecode bc, env e, sexp* stack, unsigned int top); sexp eval_in_stack(sexp obj, env e, sexp* stack, unsigned int top); From 865e7667f45714ad8277f7b850a54720700faaba Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Wed, 11 Mar 2009 18:33:49 +0900 Subject: [PATCH 028/154] adding i/o port primitives --- eval.c | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) diff --git a/eval.c b/eval.c index 70ce94d5..c9a5d249 100644 --- a/eval.c +++ b/eval.c @@ -1073,6 +1073,21 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { return stack[top-1]; } +/************************ library procedures **************************/ + +sexp sexp_open_input_file (sexp path) { + return sexp_make_input_port(fopen(sexp_string_data(path), "r")); +} + +sexp sexp_open_output_file (sexp path) { + return sexp_make_input_port(fopen(sexp_string_data(path), "w")); +} + +sexp sexp_close_port (sexp port) { + fclose(sexp_port_stream(port)); + return SEXP_UNDEF; +} + /*********************** standard environment *************************/ static const struct core_form core_forms[] = { @@ -1138,6 +1153,10 @@ _OP(OPC_GENERIC, OP_ERROR, 1, SEXP_STRING, 0, 0, 0, "error"), {SEXP_OPCODE, OPC_IO, OP_READ_CHAR, 0, 1, 0, SEXP_IPORT, 0, "read-char", (sexp)&cur_input_port, NULL}, _FN1(SEXP_PAIR, "reverse", sexp_reverse), _FN1(SEXP_PAIR, "list->vector", sexp_list_to_vector), +_FN1(SEXP_STRING, "open-input-file", sexp_open_input_file), +_FN1(SEXP_STRING, "open-output-file", sexp_open_output_file), +_FN1(SEXP_IPORT, "close-input-port", sexp_close_port), +_FN1(SEXP_OPORT, "close-output-port", sexp_close_port), _FN2(0, SEXP_PAIR, "memq", sexp_memq), _FN2(0, SEXP_PAIR, "assq", sexp_assq), _FN2(SEXP_PAIR, SEXP_PAIR, "diffq", sexp_lset_diff), From a1545e27fd75c63d118b301fb6f30c0368c10aa3 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Wed, 11 Mar 2009 19:03:31 +0900 Subject: [PATCH 029/154] adding init.scm loading --- eval.c | 62 +++++++++++++++++++++++++++++++++++++++++++++------------- eval.h | 2 ++ 2 files changed, 50 insertions(+), 14 deletions(-) diff --git a/eval.c b/eval.c index c9a5d249..c2e95d90 100644 --- a/eval.c +++ b/eval.c @@ -11,6 +11,7 @@ static int scheme_initialized_p = 0; static sexp cur_input_port, cur_output_port, cur_error_port; static sexp exception_handler_cell; static sexp continuation_resumer; +static sexp interaction_environment; #if USE_DEBUG #include "debug.c" @@ -98,33 +99,30 @@ static void shrink_bcode(bytecode *bc, unsigned int i) { } } -static void emit(bytecode *bc, unsigned int *i, char c) { +static void expand_bcode(bytecode *bc, unsigned int *i, unsigned int size) { bytecode tmp; - if ((*bc)->len < (*i)+1) { - /* fprintf(stderr, "expanding (%d < %d)\n", (*bc)->len, (*i)+1); */ + if ((*bc)->len < (*i)+size) { tmp = (bytecode) SEXP_ALLOC(sizeof(unsigned int) + (*bc)->len*2); tmp->len = (*bc)->len*2; memcpy(tmp->data, (*bc)->data, (*bc)->len); SEXP_FREE(*bc); *bc = tmp; } +} + +static void emit(bytecode *bc, unsigned int *i, char c) { + expand_bcode(bc, i, 1); (*bc)->data[(*i)++] = c; } static void emit_word(bytecode *bc, unsigned int *i, sexp_uint_t val) { - bytecode tmp; - if ((*bc)->len < (*i)+4) { - tmp = (bytecode) SEXP_ALLOC(sizeof(unsigned int) + (*bc)->len*2); - tmp->len = (*bc)->len*2; - memcpy(tmp->data, (*bc)->data, (*bc)->len); - SEXP_FREE(*bc); - *bc = tmp; - } + expand_bcode(bc, i, sizeof(sexp)); *((unsigned long*)(&((*bc)->data[*i]))) = val; *i += sizeof(unsigned long); } -#define emit_push(bc,i,obj) (emit(bc,i,OP_PUSH), emit_word(bc,i,(sexp_uint_t)obj)) +#define emit_push(bc,i,obj) (emit(bc,i,OP_PUSH), \ + emit_word(bc,i,(sexp_uint_t)obj)) static sexp sexp_make_procedure(char flags, unsigned short num_args, sexp bc, sexp vars) { @@ -1088,6 +1086,20 @@ sexp sexp_close_port (sexp port) { return SEXP_UNDEF; } +sexp sexp_load (sexp source) { + sexp obj, *stack=SEXP_ALLOC(sizeof(sexp)*INIT_STACK_SIZE); + int closep = 0; + if (SEXP_STRINGP(source)) { + source = sexp_open_input_file(source); + closep = 1; + } + while ((obj=sexp_read(source)) != (sexp) SEXP_EOF) + eval_in_stack(obj, (env) interaction_environment, stack, 0); + if (closep) sexp_close_port(source); + SEXP_FREE(stack); + return SEXP_UNDEF; +} + /*********************** standard environment *************************/ static const struct core_form core_forms[] = { @@ -1157,6 +1169,7 @@ _FN1(SEXP_STRING, "open-input-file", sexp_open_input_file), _FN1(SEXP_STRING, "open-output-file", sexp_open_output_file), _FN1(SEXP_IPORT, "close-input-port", sexp_close_port), _FN1(SEXP_OPORT, "close-output-port", sexp_close_port), +_FN1(0, "load", sexp_load), _FN2(0, SEXP_PAIR, "memq", sexp_memq), _FN2(0, SEXP_PAIR, "assq", sexp_assq), _FN2(SEXP_PAIR, SEXP_PAIR, "diffq", sexp_lset_diff), @@ -1238,11 +1251,13 @@ int main (int argc, char **argv) { sexp obj, res, in, out, *stack, err_handler, err_handler_sym; env e; bytecode bc; - unsigned int i, quit=0; + unsigned int i, quit=0, init_loaded=0; + FILE *stream; scheme_init(); stack = (sexp*) SEXP_ALLOC(sizeof(sexp) * INIT_STACK_SIZE); e = make_standard_env(); + interaction_environment = (sexp) e; bc = (bytecode) SEXP_ALLOC(sizeof(struct bytecode)+16); bc->tag = SEXP_BYTECODE; bc->len = 16; @@ -1261,6 +1276,13 @@ int main (int argc, char **argv) { switch (argv[i][1]) { case 'e': case 'p': + if (! init_loaded) { + if (stream = fopen(sexp_init_file, "r")) { + sexp_load(sexp_make_input_port(stream)); + fclose(stream); + } + init_loaded = 1; + } obj = sexp_read_from_string(argv[i+1]); res = eval_in_stack(obj, e, stack, 0); if (argv[i][1] == 'p') { @@ -1270,12 +1292,24 @@ int main (int argc, char **argv) { quit=1; i++; break; + case 'q': + init_loaded = 1; + break; default: errx(1, "unknown option: %s", argv[i]); } } - if (! quit) repl(e, stack); + if (! quit) { + if (! init_loaded) { + if (stream = fopen(sexp_init_file, "r")) { + sexp_load(sexp_make_input_port(stream)); + fclose(stream); + } + init_loaded = 1; + } + repl(e, stack); + } return 0; } diff --git a/eval.h b/eval.h index 766d2784..c22a2054 100644 --- a/eval.h +++ b/eval.h @@ -12,6 +12,8 @@ #define INIT_BCODE_SIZE 128 #define INIT_STACK_SIZE 1024 +#define sexp_init_file "init.scm" + #define sexp_debug(msg, obj) (sexp_write_string(msg,cur_error_port), sexp_write(obj, cur_error_port), sexp_write_char('\n',cur_error_port)) typedef sexp (*sexp_proc0) (); From 854bb85d105d3abcc6e53ed8d264e9edf997d18c Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Wed, 11 Mar 2009 19:40:04 +0900 Subject: [PATCH 030/154] adding initial init.scm --- eval.c | 2 +- init.scm | 51 +++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 52 insertions(+), 1 deletion(-) create mode 100644 init.scm diff --git a/eval.c b/eval.c index c2e95d90..716500fc 100644 --- a/eval.c +++ b/eval.c @@ -610,7 +610,7 @@ bytecode compile(sexp params, sexp obj, env e, sexp fv, sexp sv, int done_p) { emit(&bc, &i, OP_DROP); } else { analyze(SEXP_CAR(obj), &bc, &i, e, params, fv, sv, &d, - ! done_p && ! SEXP_PAIRP(internals)); + (! done_p) && (! SEXP_PAIRP(internals))); } } if (SEXP_PAIRP(internals)) { diff --git a/init.scm b/init.scm new file mode 100644 index 00000000..af5a820e --- /dev/null +++ b/init.scm @@ -0,0 +1,51 @@ + +;; provide c[ad]{2,4}r + +(define (caar x) (car (car x))) +(define (cadr x) (car (cdr x))) +(define (cdar x) (cdr (car x))) +(define (cddr x) (cdr (cdr x))) + +(define (caaar x) (car (car (car x)))) +(define (caadr x) (car (car (cdr x)))) +(define (cadar x) (car (cdr (car x)))) +(define (caddr x) (car (cdr (cdr x)))) +(define (cdaar x) (cdr (car (car x)))) +(define (cdadr x) (cdr (car (cdr x)))) +(define (cddar x) (cdr (cdr (car x)))) +(define (cdddr x) (cdr (cdr (cdr x)))) + +(define (caaaar x) (car (car (car (car x))))) +(define (caaadr x) (car (car (car (cdr x))))) +(define (caadar x) (car (car (cdr (car x))))) +(define (caaddr x) (car (car (cdr (cdr x))))) +(define (cadaar x) (car (cdr (car (car x))))) +(define (cadadr x) (car (cdr (car (cdr x))))) +(define (caddar x) (car (cdr (cdr (car x))))) +(define (cadddr x) (car (cdr (cdr (cdr x))))) +(define (cdaaar x) (cdr (car (car (car x))))) +(define (cdaadr x) (cdr (car (car (cdr x))))) +(define (cdadar x) (cdr (car (cdr (car x))))) +(define (cdaddr x) (cdr (car (cdr (cdr x))))) +(define (cddaar x) (cdr (cdr (car (car x))))) +(define (cddadr x) (cdr (cdr (car (cdr x))))) +(define (cdddar x) (cdr (cdr (cdr (car x))))) +(define (cddddr x) (cdr (cdr (cdr (cdr x))))) + +;; map with a fast-path for single lists + +(define (map proc ls . lol) + (if (null? lol) + (map1 proc ls '()) + (mapn proc (cons ls lol) '()))) + +(define (map1 proc ls res) + (if (pair? ls) + (map1 proc (cdr ls) (cons (proc (car ls)) res)) + (reverse res))) + +(define (mapn proc lol res) + (if (null? lol) + (reverse res) + (mapn proc (cdr lol) (cons (apply proc (map1 car lol)) res)))) + From 5caa12412e95390fd314026f4f4498c072fdd2eb Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 12 Mar 2009 19:14:34 +0900 Subject: [PATCH 031/154] bugfixes --- debug.c | 2 +- eval.c | 71 ++++++++++++++++++++++++++------------------------------ eval.h | 2 -- init.scm | 2 ++ sexp.c | 2 +- 5 files changed, 37 insertions(+), 42 deletions(-) diff --git a/debug.c b/debug.c index 9871030e..391f456e 100644 --- a/debug.c +++ b/debug.c @@ -9,7 +9,7 @@ static const char* reverse_opcode_names[] = "JUMP-UNLESS", "JUMP", "RET", "DONE", "PARAMETER", "STACK-REF", "STACK-SET", "GLOBAL-REF", "GLOBAL-SET", "CLOSURE-REF", "VECTOR-REF", "VECTOR-SET", "STRING-REF", "STRING-SET", "MAKE-PROCEDURE", - "MAKE-VECTOR", "PUSH", "DUP", "DROP", "SWAP", "PAIRP", "NULLP", "VECTORP", + "MAKE-VECTOR", "PUSH", "DROP", "PAIRP", "NULLP", "VECTORP", "INTEGERP", "SYMBOLP", "STRINGP", "CHARP", "EOFP", "PROCEDUREP", "IPORTP", "OPORTP", "CAR", "CDR", "SET-CAR", "SET-CDR", "CONS", "ADD", "SUB", "MUL", "DIV", "MOD", "NEG", "INV", "LT", "LE", "GT", "GE", "EQN", "EQ", diff --git a/eval.c b/eval.c index 716500fc..e4a94cc4 100644 --- a/eval.c +++ b/eval.c @@ -329,15 +329,12 @@ void analyze_opcode (opcode op, sexp obj, bytecode *bc, unsigned int *i, env e, if (tmp1 == 0) { errx(1, "opcode with no arguments: %s", op->name); } else if (tmp1 == 1) { + analyze(SEXP_CADR(obj), bc, i, e, params, fv, sv, d, 0); if (op->op_class == OPC_ARITHMETIC_INV) { - analyze(SEXP_CADR(obj), bc, i, e, params, fv, sv, d, 0); emit(bc, i, op->op_inverse); - } else { - analyze(SEXP_CADR(obj), bc, i, e, params, fv, sv, d, 0); - if (op->op_class != OPC_ARITHMETIC) { - emit(bc, i, op->op_name); - (*d)--; - } + (*d)++; + } else if (op->op_class != OPC_ARITHMETIC) { + emit(bc, i, op->op_name); } } else { for (o1 = sexp_reverse(SEXP_CDR(obj)); SEXP_PAIRP(o1); @@ -358,6 +355,7 @@ void analyze_opcode (opcode op, sexp obj, bytecode *bc, unsigned int *i, env e, emit(bc, i, OP_PARAMETER); emit_word(bc, i, (sexp_uint_t) op->data); (*d)++; + tmp1++; } for (o1 = sexp_reverse(SEXP_CDR(obj)); SEXP_PAIRP(o1); o1 = SEXP_CDR(o1)) @@ -390,16 +388,18 @@ void analyze_var_ref (sexp obj, bytecode *bc, unsigned int *i, env e, /* sexp_write(sv, stderr); */ /* fprintf(stderr, "\n"); */ if ((tmp = sexp_list_index(params, obj)) >= 0) { - /* fprintf(stderr, "compiling local ref: %p => %d (d = %d)\n", obj, tmp, *d); */ o1 = env_cell(e, obj); + fprintf(stderr, "compiling local ref: "); + sexp_write(obj, cur_error_port); + fprintf(stderr, " => %d\n", *d - sexp_unbox_integer(SEXP_CDR(o1))); emit(bc, i, OP_STACK_REF); emit_word(bc, i, *d - sexp_unbox_integer(SEXP_CDR(o1))); } else if ((tmp = sexp_list_index(fv, obj)) >= 0) { - /* fprintf(stderr, "compiling closure ref: %p => %d\n", obj, tmp); */ + fprintf(stderr, "compiling closure ref: %p => %d\n", obj, tmp); emit(bc, i, OP_CLOSURE_REF); emit_word(bc, i, (sexp_uint_t) sexp_make_integer(tmp)); } else { - /* fprintf(stderr, "compiling global ref: %p\n", obj); */ + fprintf(stderr, "compiling global ref: %p\n", obj); emit(bc, i, OP_GLOBAL_REF); emit_word(bc, i, (sexp_uint_t) obj); } @@ -433,6 +433,8 @@ void analyze_app (sexp obj, bytecode *bc, unsigned int *i, env e, emit(bc, i, OP_CALL); emit_word(bc, i, (sexp_uint_t) sexp_make_integer(len)); } + + (*d) -= (len); } sexp free_vars (env e, sexp formals, sexp obj, sexp fv) { @@ -572,8 +574,8 @@ bytecode compile(sexp params, sexp obj, env e, sexp fv, sexp sv, int done_p) { /* determine internal defines */ if (e->parent) { for (ls=SEXP_NULL; SEXP_PAIRP(obj); obj=SEXP_CDR(obj)) { - core = SEXP_PAIRP(SEXP_CAR(obj)) && SEXP_SYMBOLP(SEXP_CAAR(obj)) - && core_code(e, SEXP_CAAR(obj)); + core = (SEXP_PAIRP(SEXP_CAR(obj)) && SEXP_SYMBOLP(SEXP_CAAR(obj)) + ? core_code(e, SEXP_CAAR(obj)) : 0); if (core == CORE_BEGIN) { obj = sexp_cons(SEXP_CAR(obj), sexp_append(SEXP_CDAR(obj), SEXP_CDR(obj))); @@ -591,11 +593,11 @@ bytecode compile(sexp params, sexp obj, env e, sexp fv, sexp sv, int done_p) { } } obj = sexp_reverse(ls); -/* sexp_write_string("internals: ", cur_error_port); */ -/* sexp_write(internals, cur_error_port); */ -/* sexp_write_string("\n", cur_error_port); */ j = sexp_length(internals); if (SEXP_PAIRP(internals)) { +/* sexp_write_string("internals: ", cur_error_port); */ +/* sexp_write(internals, cur_error_port); */ +/* sexp_write_string("\n", cur_error_port); */ e = extend_env_closure(e, internals, 2); params = sexp_append(internals, params); for (ls=internals; SEXP_PAIRP(ls); ls=SEXP_CDR(ls)) @@ -608,6 +610,7 @@ bytecode compile(sexp params, sexp obj, env e, sexp fv, sexp sv, int done_p) { if (SEXP_PAIRP(SEXP_CDR(obj))) { analyze(SEXP_CAR(obj), &bc, &i, e, params, fv, sv, &d, 0); emit(&bc, &i, OP_DROP); + d--; } else { analyze(SEXP_CAR(obj), &bc, &i, e, params, fv, sv, &d, (! done_p) && (! SEXP_PAIRP(internals))); @@ -654,6 +657,7 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { int i, j, k; loop: +/* print_stack(stack, top); */ /* fprintf(stderr, "OP: %s (%d)\n", (*ip<=71) ? reverse_opcode_names[*ip] : "", *ip); */ switch (*ip++) { case OP_NOOP: @@ -732,24 +736,16 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { stack[top++]=((sexp*)ip)[0]; ip += sizeof(sexp); break; - case OP_DUP: - stack[top]=stack[top-1]; - top++; - break; case OP_DROP: top--; break; - case OP_SWAP: - tmp1 = stack[top-2]; - stack[top-2]=stack[top-1]; - stack[top-1]=tmp1; - break; case OP_PARAMETER: stack[top] = *(sexp*)((sexp*)ip)[0]; top++; ip += sizeof(sexp); break; case OP_PAIRP: + /* print_stack(stack, top); */ stack[top-1]=SEXP_PAIRP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break; case OP_NULLP: stack[top-1]=SEXP_NULLP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break; @@ -772,6 +768,7 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { case OP_EOFP: stack[top-1]=(stack[top-1] == SEXP_EOF) ? SEXP_TRUE : SEXP_FALSE; break; case OP_CAR: + /* print_stack(stack, top); */ if (! SEXP_PAIRP(stack[top-1])) sexp_raise(sexp_intern("not-a-pair")); stack[top-1]=SEXP_CAR(stack[top-1]); break; case OP_CDR: @@ -842,17 +839,16 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { /* fprintf(stderr, "tail call: depth=%d, i=%d, top=%d\n", j, i, top); */ /* print_stack(stack, top); */ /* save frame info */ - stack[top] = stack[top-i-j]; - stack[top+1] = stack[top-i-j+1]; + stack[top] = stack[top-j-2]; + stack[top+1] = stack[top-j-1]; /* copy new args into place */ for (k=top-i-1; ktag = SEXP_ENV; e->parent = NULL; e->bindings = SEXP_NULL; - for (i=0; i<(sizeof(core_forms)/sizeof(struct core_form)); i++) { + for (i=0; i<(sizeof(core_forms)/sizeof(struct core_form)); i++) env_define(e, sexp_intern(core_forms[i].name), (sexp)(&core_forms[i])); - } - for (i=0; i<(sizeof(opcodes)/sizeof(struct opcode)); i++) { + for (i=0; i<(sizeof(opcodes)/sizeof(struct opcode)); i++) env_define(e, sexp_intern(opcodes[i].name), (sexp)(&opcodes[i])); - } return e; } diff --git a/eval.h b/eval.h index c22a2054..f4204a8d 100644 --- a/eval.h +++ b/eval.h @@ -131,9 +131,7 @@ enum opcode_names { OP_MAKE_PROCEDURE, OP_MAKE_VECTOR, OP_PUSH, - OP_DUP, OP_DROP, - OP_SWAP, OP_PAIRP, OP_NULLP, OP_VECTORP, diff --git a/init.scm b/init.scm index af5a820e..e8c1a823 100644 --- a/init.scm +++ b/init.scm @@ -40,6 +40,8 @@ (mapn proc (cons ls lol) '()))) (define (map1 proc ls res) +;; (write ls) +;; (newline) (if (pair? ls) (map1 proc (cdr ls) (cons (proc (car ls)) res)) (reverse res))) diff --git a/sexp.c b/sexp.c index f20d4607..6fa9cb3e 100644 --- a/sexp.c +++ b/sexp.c @@ -406,7 +406,7 @@ void sexp_write (sexp obj, sexp out) { case SEXP_FLONUM: sexp_printf(out, "%g", sexp_flonum_value(obj)); break; case SEXP_PROCEDURE: - sexp_write_string("#", out); break; + sexp_printf(out, "#", obj); break; case SEXP_IPORT: sexp_write_string("#", out); break; case SEXP_OPORT: From 1ad276252f3bf9e558907209e635dc72fadb51e7 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Fri, 13 Mar 2009 22:56:43 +0900 Subject: [PATCH 032/154] fixing tail calls, now allowing variadic tail calls --- eval.c | 58 +++++++++++++++++++------------------- init.scm | 86 ++++++++++++++++++++++++++++++++++++++------------------ 2 files changed, 88 insertions(+), 56 deletions(-) diff --git a/eval.c b/eval.c index e4a94cc4..6de393be 100644 --- a/eval.c +++ b/eval.c @@ -373,7 +373,7 @@ void analyze_opcode (opcode op, sexp obj, bytecode *bc, unsigned int *i, env e, } emit_push(bc, i, op->data); emit(bc, i, op->op_name); - (*d) -= sexp_length(SEXP_CDR(obj)); + (*d) -= (sexp_length(SEXP_CDR(obj))-1); break; default: errx(1, "unknown opcode class: %d", op->op_class); @@ -425,8 +425,10 @@ void analyze_app (sexp obj, bytecode *bc, unsigned int *i, env e, /* maybe overwrite the current frame */ if (tailp) { + fprintf(stderr, "compiling tail call: %d + %d + 3 = %d\n", + sexp_length(params), (*d), sexp_length(params)+(*d)+3); emit(bc, i, OP_TAIL_CALL); - emit_word(bc, i, (sexp_uint_t) sexp_make_integer(sexp_length(params)+(*d))); + emit_word(bc, i, (sexp_uint_t) sexp_make_integer(sexp_length(params)+(*d)+3)); emit_word(bc, i, (sexp_uint_t) sexp_make_integer(len)); } else { /* normal call */ @@ -613,7 +615,8 @@ bytecode compile(sexp params, sexp obj, env e, sexp fv, sexp sv, int done_p) { d--; } else { analyze(SEXP_CAR(obj), &bc, &i, e, params, fv, sv, &d, - (! done_p) && (! SEXP_PAIRP(internals))); + (! done_p) && (! SEXP_PAIRP(internals)) + ); } } if (SEXP_PAIRP(internals)) { @@ -667,6 +670,11 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { tmp1 = env_cell(e, ((sexp*)ip)[0]); if (! tmp1) sexp_raise(sexp_intern("undefined-variable")); +/* fprintf(stderr, "global-ref: "); */ +/* sexp_write(((sexp*)ip)[0], cur_error_port); */ +/* fprintf(stderr, " => "); */ +/* sexp_write(SEXP_CDR(tmp1), cur_error_port); */ +/* fprintf(stderr, "\n"); */ stack[top++]=SEXP_CDR(tmp1); ip += sizeof(sexp); break; @@ -745,7 +753,6 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { ip += sizeof(sexp); break; case OP_PAIRP: - /* print_stack(stack, top); */ stack[top-1]=SEXP_PAIRP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break; case OP_NULLP: stack[top-1]=SEXP_NULLP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break; @@ -832,36 +839,23 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { top--; break; case OP_TAIL_CALL: + /* old-args ... n ret-ip ret-cp new-args ... proc */ + /* [================= j ===========================] */ + /* [==== i =====] */ j = sexp_unbox_integer(((sexp*)ip)[0]); /* current depth */ - ip += sizeof(sexp); - i = sexp_unbox_integer(((sexp*)ip)[0]); /* number of params */ + i = sexp_unbox_integer(((sexp*)ip)[1]); /* number of params */ tmp1 = stack[top-1]; /* procedure to call */ -/* fprintf(stderr, "tail call: depth=%d, i=%d, top=%d\n", j, i, top); */ -/* print_stack(stack, top); */ /* save frame info */ - stack[top] = stack[top-j-2]; - stack[top+1] = stack[top-j-1]; + ip = ((unsigned char*) sexp_unbox_integer(stack[top-i-3])) - sizeof(sexp); + cp = stack[top-i-2]; /* copy new args into place */ - for (k=top-i-1; kdata); */ - bc = sexp_procedure_code(tmp1); - ip = bc->data; - cp = sexp_procedure_vars(tmp1); - break; + for (k=0; k= INIT_STACK_SIZE) errx(1, "out of stack space: %d", top); - /* fprintf(stderr, "CALL\n"); */ - /* print_stack(stack, top); */ i = sexp_unbox_integer(((sexp*)ip)[0]); tmp1 = stack[top-1]; make_call: @@ -870,12 +864,18 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { tmp1 = make_opcode_procedure((opcode) tmp1, i, e); /* print_stack(stack, top); */ if (! SEXP_PROCEDUREP(tmp1)) { - fprintf(stderr, "error: non-procedure app\n"); + fprintf(stderr, "error: non-procedure app: "); + sexp_write(tmp1, cur_error_port); + fprintf(stderr, "\n"); sexp_raise(sexp_intern("non-procedure-application")); } j = i - sexp_unbox_integer(sexp_procedure_num_args(tmp1)); - if (j < 0) + if (j < 0) { + fprintf(stderr, "error: expected %d args but got %d\n", + sexp_unbox_integer(sexp_procedure_num_args(tmp1)), + i); sexp_raise(sexp_intern("not-enough-args")); + } if (j > 0) { if (sexp_procedure_variadic_p(tmp1)) { stack[top-i-1] = sexp_cons(stack[top-i-1], SEXP_NULL); diff --git a/init.scm b/init.scm index e8c1a823..5521a917 100644 --- a/init.scm +++ b/init.scm @@ -6,31 +6,48 @@ (define (cdar x) (cdr (car x))) (define (cddr x) (cdr (cdr x))) -(define (caaar x) (car (car (car x)))) -(define (caadr x) (car (car (cdr x)))) -(define (cadar x) (car (cdr (car x)))) -(define (caddr x) (car (cdr (cdr x)))) -(define (cdaar x) (cdr (car (car x)))) -(define (cdadr x) (cdr (car (cdr x)))) -(define (cddar x) (cdr (cdr (car x)))) -(define (cdddr x) (cdr (cdr (cdr x)))) +;; (define (caaar x) (car (car (car x)))) +;; (define (caadr x) (car (car (cdr x)))) +;; (define (cadar x) (car (cdr (car x)))) +;; (define (caddr x) (car (cdr (cdr x)))) +;; (define (cdaar x) (cdr (car (car x)))) +;; (define (cdadr x) (cdr (car (cdr x)))) +;; (define (cddar x) (cdr (cdr (car x)))) +;; (define (cdddr x) (cdr (cdr (cdr x)))) -(define (caaaar x) (car (car (car (car x))))) -(define (caaadr x) (car (car (car (cdr x))))) -(define (caadar x) (car (car (cdr (car x))))) -(define (caaddr x) (car (car (cdr (cdr x))))) -(define (cadaar x) (car (cdr (car (car x))))) -(define (cadadr x) (car (cdr (car (cdr x))))) -(define (caddar x) (car (cdr (cdr (car x))))) -(define (cadddr x) (car (cdr (cdr (cdr x))))) -(define (cdaaar x) (cdr (car (car (car x))))) -(define (cdaadr x) (cdr (car (car (cdr x))))) -(define (cdadar x) (cdr (car (cdr (car x))))) -(define (cdaddr x) (cdr (car (cdr (cdr x))))) -(define (cddaar x) (cdr (cdr (car (car x))))) -(define (cddadr x) (cdr (cdr (car (cdr x))))) -(define (cdddar x) (cdr (cdr (cdr (car x))))) -(define (cddddr x) (cdr (cdr (cdr (cdr x))))) +;; (define (caaaar x) (car (car (car (car x))))) +;; (define (caaadr x) (car (car (car (cdr x))))) +;; (define (caadar x) (car (car (cdr (car x))))) +;; (define (caaddr x) (car (car (cdr (cdr x))))) +;; (define (cadaar x) (car (cdr (car (car x))))) +;; (define (cadadr x) (car (cdr (car (cdr x))))) +;; (define (caddar x) (car (cdr (cdr (car x))))) +;; (define (cadddr x) (car (cdr (cdr (cdr x))))) +;; (define (cdaaar x) (cdr (car (car (car x))))) +;; (define (cdaadr x) (cdr (car (car (cdr x))))) +;; (define (cdadar x) (cdr (car (cdr (car x))))) +;; (define (cdaddr x) (cdr (car (cdr (cdr x))))) +;; (define (cddaar x) (cdr (cdr (car (car x))))) +;; (define (cddadr x) (cdr (cdr (car (cdr x))))) +;; (define (cdddar x) (cdr (cdr (cdr (car x))))) +;; (define (cddddr x) (cdr (cdr (cdr (cdr x))))) + +(define (list . args) args) + +(define (append-reverse a b) + (if (pair? a) + (append-reverse (cdr a) (cons (car a) b)) + b)) + +(define (append a b) + (append-reverse (reverse a) b)) + +(define (apply proc . args) + (if (null? args) + (proc) + ((lambda (lol) + (apply1 proc (append (reverse (cdr lol)) (car lol)))) + (reverse args)))) ;; map with a fast-path for single lists @@ -40,8 +57,6 @@ (mapn proc (cons ls lol) '()))) (define (map1 proc ls res) -;; (write ls) -;; (newline) (if (pair? ls) (map1 proc (cdr ls) (cons (proc (car ls)) res)) (reverse res))) @@ -49,5 +64,22 @@ (define (mapn proc lol res) (if (null? lol) (reverse res) - (mapn proc (cdr lol) (cons (apply proc (map1 car lol)) res)))) + (mapn proc (cdr lol) (cons (apply1 proc (map1 car lol '())) res)))) +;; syntax + +(define-syntax let + (lambda (expr use-env mac-env) + (cons (cons 'lambda (cons (map car (cadr expr)) (cddr expr))) + (map cadr (cadr expr))))) + +(define-syntax or + (lambda (expr use-env mac-env) + (if (null? (cdr expr)) + #f + (if (null? (cddr expr)) + (cadr expr) + (list 'let (list (list 'tmp (cadr expr))) + (list 'if 'tmp + 'tmp + (cons 'or (cddr expr)))))))) From 4ec2c98a5809b2c48ad76ba9870905357c8b8d53 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 14 Mar 2009 11:33:54 +0900 Subject: [PATCH 033/154] fixing silly macro expander bug (forgot to initialize the i index) --- eval.c | 61 +++++++++++++++++++++++++++++--------------------------- init.scm | 26 +++++++++++++----------- 2 files changed, 46 insertions(+), 41 deletions(-) diff --git a/eval.c b/eval.c index 6de393be..e1890ec5 100644 --- a/eval.c +++ b/eval.c @@ -102,6 +102,7 @@ static void shrink_bcode(bytecode *bc, unsigned int i) { static void expand_bcode(bytecode *bc, unsigned int *i, unsigned int size) { bytecode tmp; if ((*bc)->len < (*i)+size) { + fprintf(stderr, "expanding bytecode %u < %u + %u = %u\n", (*bc)->len, (*i), size, (*i)+size); tmp = (bytecode) SEXP_ALLOC(sizeof(unsigned int) + (*bc)->len*2); tmp->len = (*bc)->len*2; memcpy(tmp->data, (*bc)->data, (*bc)->len); @@ -148,11 +149,11 @@ static sexp sexp_make_macro (procedure p, env e) { sexp sexp_expand_macro (macro mac, sexp form, env e) { sexp res, *stack = SEXP_ALLOC(sizeof(sexp)*INIT_STACK_SIZE); bytecode bc; - unsigned int i; + unsigned int i=0; fprintf(stderr, "expanding: "); sexp_write(form, cur_error_port); fprintf(stderr, "\n => "); - bc = (bytecode) SEXP_ALLOC(sizeof(struct bytecode)+32); + bc = (bytecode) SEXP_ALLOC(sizeof(struct bytecode)+64); bc->tag = SEXP_BYTECODE; bc->len = 32; emit_push(&bc, &i, mac->e); @@ -162,6 +163,7 @@ sexp sexp_expand_macro (macro mac, sexp form, env e) { emit(&bc, &i, OP_CALL); emit_word(&bc, &i, (sexp_uint_t) sexp_make_integer(3)); emit(&bc, &i, OP_DONE); + /* disasm(bc); */ res = vm(bc, e, stack, 0); sexp_write(res, cur_error_port); fprintf(stderr, "\n"); @@ -194,6 +196,8 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, case CORE_DEFINE_SYNTAX: env_define(e, SEXP_CADR(obj), sexp_make_macro((procedure) eval(SEXP_CADDR(obj), e), e)); + emit_push(bc, i, SEXP_UNDEF); + (*d)++; break; case CORE_DEFINE: if ((((core_form)o1)->code == CORE_DEFINE) @@ -271,34 +275,33 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, analyze_app(obj, bc, i, e, params, fv, sv, d, tailp); } } else if (SEXP_PAIRP(SEXP_CAR(obj))) { - o2 = env_cell(e, SEXP_CAAR(obj)); - if (o2 - && SEXP_COREP(SEXP_CDR(o2)) - && (((core_form)SEXP_CDR(o2))->code == CORE_LAMBDA) - && sexp_listp(SEXP_CADR(SEXP_CAR(obj)))) { - /* let */ - tmp1 = sexp_length(SEXP_CADR(SEXP_CAR(obj))); - e2 = extend_env_closure(e, SEXP_CADR(SEXP_CAR(obj)), (*d)); - for (o2=sexp_reverse(SEXP_CDR(obj)); SEXP_PAIRP(o2); o2=SEXP_CDR(o2)) - analyze(SEXP_CAR(o2), bc, i, e, params, fv, sv, d, 0); - params = sexp_append(SEXP_CADR(SEXP_CAR(obj)), params); - for (o2=SEXP_CDDR(SEXP_CAR(obj)); SEXP_PAIRP(o2); o2=SEXP_CDR(o2)) { - if (SEXP_PAIRP(SEXP_CDR(o2))) { - analyze(SEXP_CAR(o2), bc, i, e2, params, fv, sv, d, 0); - emit(bc, i, OP_DROP); - } else { - analyze(SEXP_CAR(o2), bc, i, e2, params, fv, sv, d, tailp); - } - } - emit(bc, i, OP_STACK_SET); - emit_word(bc, i, tmp1+1); - (*d) -= tmp1; - for (tmp1; tmp1>0; tmp1--) - emit(bc, i, OP_DROP); - } else { +/* o2 = env_cell(e, SEXP_CAAR(obj)); */ +/* if (o2 */ +/* && SEXP_COREP(SEXP_CDR(o2)) */ +/* && (((core_form)SEXP_CDR(o2))->code == CORE_LAMBDA) */ +/* && sexp_listp(SEXP_CADR(SEXP_CAR(obj)))) { */ +/* /\* let *\/ */ +/* tmp1 = sexp_length(SEXP_CADR(SEXP_CAR(obj))); */ +/* e2 = extend_env_closure(e, SEXP_CADR(SEXP_CAR(obj)), (*d)); */ +/* for (o2=sexp_reverse(SEXP_CDR(obj)); SEXP_PAIRP(o2); o2=SEXP_CDR(o2)) */ +/* analyze(SEXP_CAR(o2), bc, i, e, params, fv, sv, d, 0); */ +/* params = sexp_append(SEXP_CADR(SEXP_CAR(obj)), params); */ +/* for (o2=SEXP_CDDR(SEXP_CAR(obj)); SEXP_PAIRP(o2); o2=SEXP_CDR(o2)) { */ +/* if (SEXP_PAIRP(SEXP_CDR(o2))) { */ +/* analyze(SEXP_CAR(o2), bc, i, e2, params, fv, sv, d, 0); */ +/* emit(bc, i, OP_DROP); */ +/* } else { */ +/* analyze(SEXP_CAR(o2), bc, i, e2, params, fv, sv, d, tailp); */ +/* } */ +/* } */ +/* emit(bc, i, OP_STACK_SET); */ +/* emit_word(bc, i, tmp1+1); */ +/* (*d) -= tmp1; */ +/* for (tmp1; tmp1>0; tmp1--) */ +/* emit(bc, i, OP_DROP); */ +/* } else */ /* computed application */ - analyze_app(obj, bc, i, e, params, fv, sv, d, tailp); - } + analyze_app(obj, bc, i, e, params, fv, sv, d, tailp); } else { errx(1, "invalid operator: %s", SEXP_CAR(obj)); } diff --git a/init.scm b/init.scm index 5521a917..d68939ad 100644 --- a/init.scm +++ b/init.scm @@ -62,9 +62,11 @@ (reverse res))) (define (mapn proc lol res) - (if (null? lol) + (if (null? (car lol)) (reverse res) - (mapn proc (cdr lol) (cons (apply1 proc (map1 car lol '())) res)))) + (mapn proc + (map1 cdr lol '()) + (cons (apply1 proc (map1 car lol '())) res)))) ;; syntax @@ -73,13 +75,13 @@ (cons (cons 'lambda (cons (map car (cadr expr)) (cddr expr))) (map cadr (cadr expr))))) -(define-syntax or - (lambda (expr use-env mac-env) - (if (null? (cdr expr)) - #f - (if (null? (cddr expr)) - (cadr expr) - (list 'let (list (list 'tmp (cadr expr))) - (list 'if 'tmp - 'tmp - (cons 'or (cddr expr)))))))) +;; (define-syntax or +;; (lambda (expr use-env mac-env) +;; (if (null? (cdr expr)) +;; #f +;; (if (null? (cddr expr)) +;; (cadr expr) +;; (list 'let (list (list 'tmp (cadr expr))) +;; (list 'if 'tmp +;; 'tmp +;; (cons 'or (cddr expr)))))))) From f42a866d94bb2b287ceca5c2831936bc360ba406 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 15 Mar 2009 13:19:51 +0900 Subject: [PATCH 034/154] fixing let optimization --- config.h | 3 +++ eval.c | 56 +++++++++++++++++++++++++++++--------------------------- init.scm | 20 ++++++++++---------- 3 files changed, 42 insertions(+), 37 deletions(-) diff --git a/config.h b/config.h index 625d3117..297ab9c4 100644 --- a/config.h +++ b/config.h @@ -18,3 +18,6 @@ #define USE_STRING_STREAMS 1 #endif +#ifndef USE_FAST_LET +#define USE_FAST_LET 1 +#endif diff --git a/eval.c b/eval.c index e1890ec5..d8e16c22 100644 --- a/eval.c +++ b/eval.c @@ -275,31 +275,33 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, analyze_app(obj, bc, i, e, params, fv, sv, d, tailp); } } else if (SEXP_PAIRP(SEXP_CAR(obj))) { -/* o2 = env_cell(e, SEXP_CAAR(obj)); */ -/* if (o2 */ -/* && SEXP_COREP(SEXP_CDR(o2)) */ -/* && (((core_form)SEXP_CDR(o2))->code == CORE_LAMBDA) */ -/* && sexp_listp(SEXP_CADR(SEXP_CAR(obj)))) { */ -/* /\* let *\/ */ -/* tmp1 = sexp_length(SEXP_CADR(SEXP_CAR(obj))); */ -/* e2 = extend_env_closure(e, SEXP_CADR(SEXP_CAR(obj)), (*d)); */ -/* for (o2=sexp_reverse(SEXP_CDR(obj)); SEXP_PAIRP(o2); o2=SEXP_CDR(o2)) */ -/* analyze(SEXP_CAR(o2), bc, i, e, params, fv, sv, d, 0); */ -/* params = sexp_append(SEXP_CADR(SEXP_CAR(obj)), params); */ -/* for (o2=SEXP_CDDR(SEXP_CAR(obj)); SEXP_PAIRP(o2); o2=SEXP_CDR(o2)) { */ -/* if (SEXP_PAIRP(SEXP_CDR(o2))) { */ -/* analyze(SEXP_CAR(o2), bc, i, e2, params, fv, sv, d, 0); */ -/* emit(bc, i, OP_DROP); */ -/* } else { */ -/* analyze(SEXP_CAR(o2), bc, i, e2, params, fv, sv, d, tailp); */ -/* } */ -/* } */ -/* emit(bc, i, OP_STACK_SET); */ -/* emit_word(bc, i, tmp1+1); */ -/* (*d) -= tmp1; */ -/* for (tmp1; tmp1>0; tmp1--) */ -/* emit(bc, i, OP_DROP); */ -/* } else */ +#if USE_FAST_LET + o2 = env_cell(e, SEXP_CAAR(obj)); + if (o2 + && SEXP_COREP(SEXP_CDR(o2)) + && (((core_form)SEXP_CDR(o2))->code == CORE_LAMBDA) + && sexp_listp(SEXP_CADR(SEXP_CAR(obj)))) { + /* let */ + tmp1 = sexp_length(SEXP_CADR(SEXP_CAR(obj))); + e2 = extend_env_closure(e, SEXP_CADR(SEXP_CAR(obj)), (*d)+(tmp1-1)); + for (o2=sexp_reverse(SEXP_CDR(obj)); SEXP_PAIRP(o2); o2=SEXP_CDR(o2)) + analyze(SEXP_CAR(o2), bc, i, e, params, fv, sv, d, 0); + params = sexp_append(SEXP_CADR(SEXP_CAR(obj)), params); + for (o2=SEXP_CDDR(SEXP_CAR(obj)); SEXP_PAIRP(o2); o2=SEXP_CDR(o2)) { + if (SEXP_PAIRP(SEXP_CDR(o2))) { + analyze(SEXP_CAR(o2), bc, i, e2, params, fv, sv, d, 0); + emit(bc, i, OP_DROP); + } else { + analyze(SEXP_CAR(o2), bc, i, e2, params, fv, sv, d, tailp); + } + } + emit(bc, i, OP_STACK_SET); + emit_word(bc, i, tmp1+1); + (*d) -= (tmp1-1); + for (tmp1; tmp1>0; tmp1--) + emit(bc, i, OP_DROP); + } else +#endif /* computed application */ analyze_app(obj, bc, i, e, params, fv, sv, d, tailp); } else { @@ -663,8 +665,8 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { int i, j, k; loop: -/* print_stack(stack, top); */ -/* fprintf(stderr, "OP: %s (%d)\n", (*ip<=71) ? reverse_opcode_names[*ip] : "", *ip); */ + print_stack(stack, top); + fprintf(stderr, "OP: %s (%d)\n", (*ip<=71) ? reverse_opcode_names[*ip] : "", *ip); switch (*ip++) { case OP_NOOP: fprintf(stderr, "noop\n"); diff --git a/init.scm b/init.scm index d68939ad..33fe780a 100644 --- a/init.scm +++ b/init.scm @@ -75,13 +75,13 @@ (cons (cons 'lambda (cons (map car (cadr expr)) (cddr expr))) (map cadr (cadr expr))))) -;; (define-syntax or -;; (lambda (expr use-env mac-env) -;; (if (null? (cdr expr)) -;; #f -;; (if (null? (cddr expr)) -;; (cadr expr) -;; (list 'let (list (list 'tmp (cadr expr))) -;; (list 'if 'tmp -;; 'tmp -;; (cons 'or (cddr expr)))))))) +(define-syntax or + (lambda (expr use-env mac-env) + (if (null? (cdr expr)) + #f + (if (null? (cddr expr)) + (cadr expr) + (list 'let (list (list 'tmp (cadr expr))) + (list 'if 'tmp + 'tmp + (cons 'or (cddr expr)))))))) From f3a4e8c3101f41b39ada1841c69e6e74453a5783 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 15 Mar 2009 14:07:28 +0900 Subject: [PATCH 035/154] adding initial test suite --- Makefile | 10 ++++++++ eval.c | 54 ++++++++++++++++++----------------------- init.scm | 6 +++++ sexp.c | 35 +++++++++----------------- sexp.h | 5 ++-- tests/test00-fact-3.res | 1 + tests/test00-fact-3.scm | 14 +++++++++++ tests/test01-apply.res | 8 ++++++ tests/test01-apply.scm | 18 ++++++++++++++ tests/test02-callcc.res | 1 + tests/test02-callcc.scm | 34 ++++++++++++++++++++++++++ 11 files changed, 130 insertions(+), 56 deletions(-) create mode 100644 tests/test00-fact-3.res create mode 100644 tests/test00-fact-3.scm create mode 100644 tests/test01-apply.res create mode 100644 tests/test01-apply.scm create mode 100644 tests/test02-callcc.res create mode 100644 tests/test02-callcc.scm diff --git a/Makefile b/Makefile index c62c1921..f3ce3824 100644 --- a/Makefile +++ b/Makefile @@ -29,3 +29,13 @@ cleaner: clean rm -f chibi-scheme rm -rf *.dSYM +test: chibi-scheme + for f in tests/*.scm; do \ + ./chibi-scheme $$f >$${f%.scm}.out 2>$${f%.scm}.err; \ + if diff -q $${f%.scm}.out $${f%.scm}.res; then \ + echo "[PASS] $${f%.scm}"; \ + else \ + echo "[FAIL] $${f%.scm}"; \ + fi; \ + done + diff --git a/eval.c b/eval.c index d8e16c22..674564b5 100644 --- a/eval.c +++ b/eval.c @@ -282,7 +282,7 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, && (((core_form)SEXP_CDR(o2))->code == CORE_LAMBDA) && sexp_listp(SEXP_CADR(SEXP_CAR(obj)))) { /* let */ - tmp1 = sexp_length(SEXP_CADR(SEXP_CAR(obj))); + tmp1 = sexp_unbox_integer(sexp_length(SEXP_CADR(SEXP_CAR(obj)))); e2 = extend_env_closure(e, SEXP_CADR(SEXP_CAR(obj)), (*d)+(tmp1-1)); for (o2=sexp_reverse(SEXP_CDR(obj)); SEXP_PAIRP(o2); o2=SEXP_CDR(o2)) analyze(SEXP_CAR(o2), bc, i, e, params, fv, sv, d, 0); @@ -330,7 +330,7 @@ void analyze_opcode (opcode op, sexp obj, bytecode *bc, unsigned int *i, env e, case OPC_CONSTRUCTOR: case OPC_ACCESSOR: case OPC_GENERIC: - tmp1 = sexp_length(SEXP_CDR(obj)); + tmp1 = sexp_unbox_integer(sexp_length(SEXP_CDR(obj))); if (tmp1 == 0) { errx(1, "opcode with no arguments: %s", op->name); } else if (tmp1 == 1) { @@ -355,7 +355,7 @@ void analyze_opcode (opcode op, sexp obj, bytecode *bc, unsigned int *i, env e, } break; case OPC_IO: - tmp1 = sexp_length(SEXP_CDR(obj)); + tmp1 = sexp_unbox_integer(sexp_length(SEXP_CDR(obj))); if (tmp1 == op->num_args && op->var_args_p) { emit(bc, i, OP_PARAMETER); emit_word(bc, i, (sexp_uint_t) op->data); @@ -378,7 +378,7 @@ void analyze_opcode (opcode op, sexp obj, bytecode *bc, unsigned int *i, env e, } emit_push(bc, i, op->data); emit(bc, i, op->op_name); - (*d) -= (sexp_length(SEXP_CDR(obj))-1); + (*d) -= (sexp_unbox_integer(sexp_length(SEXP_CDR(obj)))-1); break; default: errx(1, "unknown opcode class: %d", op->op_class); @@ -418,7 +418,7 @@ void analyze_var_ref (sexp obj, bytecode *bc, unsigned int *i, env e, void analyze_app (sexp obj, bytecode *bc, unsigned int *i, env e, sexp params, sexp fv, sexp sv, unsigned int *d, int tailp) { sexp o1; - unsigned long len = sexp_length(SEXP_CDR(obj)); + sexp_uint_t len = sexp_unbox_integer(sexp_length(SEXP_CDR(obj))); /* push the arguments onto the stack */ for (o1 = sexp_reverse(SEXP_CDR(obj)); SEXP_PAIRP(o1); o1 = SEXP_CDR(o1)) { @@ -430,10 +430,8 @@ void analyze_app (sexp obj, bytecode *bc, unsigned int *i, env e, /* maybe overwrite the current frame */ if (tailp) { - fprintf(stderr, "compiling tail call: %d + %d + 3 = %d\n", - sexp_length(params), (*d), sexp_length(params)+(*d)+3); emit(bc, i, OP_TAIL_CALL); - emit_word(bc, i, (sexp_uint_t) sexp_make_integer(sexp_length(params)+(*d)+3)); + emit_word(bc, i, (sexp_uint_t) sexp_make_integer(sexp_unbox_integer(sexp_length(params))+(*d)+3)); emit_word(bc, i, (sexp_uint_t) sexp_make_integer(len)); } else { /* normal call */ @@ -514,7 +512,7 @@ void analyze_lambda (sexp name, sexp formals, sexp body, obj = (sexp) compile(flat_formals, body, e2, fv2, sv, 0); /* push the closed vars */ emit_push(bc, i, SEXP_UNDEF); - emit_push(bc, i, sexp_make_integer(sexp_length(fv2))); + emit_push(bc, i, sexp_length(fv2)); emit(bc, i, OP_MAKE_VECTOR); (*d)++; for (ls=fv2, k=0; SEXP_PAIRP(ls); ls=SEXP_CDR(ls), k++) { @@ -528,7 +526,7 @@ void analyze_lambda (sexp name, sexp formals, sexp body, } /* push the additional procedure info and make the closure */ emit_push(bc, i, obj); - emit_push(bc, i, sexp_make_integer(sexp_length(formals))); + emit_push(bc, i, sexp_length(formals)); emit_push(bc, i, sexp_make_integer(sexp_listp(formals) ? 0 : 1)); emit(bc, i, OP_MAKE_PROCEDURE); } @@ -600,7 +598,7 @@ bytecode compile(sexp params, sexp obj, env e, sexp fv, sexp sv, int done_p) { } } obj = sexp_reverse(ls); - j = sexp_length(internals); + j = sexp_unbox_integer(sexp_length(internals)); if (SEXP_PAIRP(internals)) { /* sexp_write_string("internals: ", cur_error_port); */ /* sexp_write(internals, cur_error_port); */ @@ -642,7 +640,7 @@ bytecode compile(sexp params, sexp obj, env e, sexp fv, sexp sv, int done_p) { sexp sexp_save_stack(sexp *stack, unsigned int to) { sexp res, *data; int i; - res = sexp_make_vector(to, SEXP_UNDEF); + res = sexp_make_vector(sexp_make_integer(to), SEXP_UNDEF); data = sexp_vector_data(res); for (i=0; idata; @@ -1164,6 +1163,7 @@ _OP(OPC_GENERIC, OP_ERROR, 1, SEXP_STRING, 0, 0, 0, "error"), {SEXP_OPCODE, OPC_IO, OP_FLUSH_OUTPUT, 0, 1, 0, SEXP_OPORT, 0, "flush-output", (sexp)&cur_output_port, NULL}, {SEXP_OPCODE, OPC_IO, OP_READ, 0, 1, 0, SEXP_IPORT, 0, "read", (sexp)&cur_input_port, NULL}, {SEXP_OPCODE, OPC_IO, OP_READ_CHAR, 0, 1, 0, SEXP_IPORT, 0, "read-char", (sexp)&cur_input_port, NULL}, +_FN1(SEXP_PAIR, "length", sexp_length), _FN1(SEXP_PAIR, "reverse", sexp_reverse), _FN1(SEXP_PAIR, "list->vector", sexp_list_to_vector), _FN1(SEXP_STRING, "open-input-file", sexp_open_input_file), @@ -1269,18 +1269,13 @@ int main (int argc, char **argv) { env_define(e, err_handler_sym, err_handler); exception_handler_cell = env_cell(e, err_handler_sym); - fprintf(stderr, "current-input-port: %d => %d\n", &cur_input_port, cur_input_port); - /* parse options */ for (i=1; i < argc && argv[i][0] == '-'; i++) { switch (argv[i][1]) { case 'e': case 'p': if (! init_loaded) { - if (stream = fopen(sexp_init_file, "r")) { - sexp_load(sexp_make_input_port(stream)); - fclose(stream); - } + sexp_load(sexp_make_string(sexp_init_file)); init_loaded = 1; } obj = sexp_read_from_string(argv[i+1]); @@ -1301,14 +1296,13 @@ int main (int argc, char **argv) { } if (! quit) { - if (! init_loaded) { - if (stream = fopen(sexp_init_file, "r")) { - sexp_load(sexp_make_input_port(stream)); - fclose(stream); - } - init_loaded = 1; - } - repl(e, stack); + if (! init_loaded) + sexp_load(sexp_make_string(sexp_init_file)); + if (i < argc) + for ( ; i < argc; i++) + sexp_load(sexp_make_string(argv[i])); + else + repl(e, stack); } return 0; } diff --git a/init.scm b/init.scm index 33fe780a..46afc7e2 100644 --- a/init.scm +++ b/init.scm @@ -68,6 +68,12 @@ (map1 cdr lol '()) (cons (apply1 proc (map1 car lol '())) res)))) +;; math utilities + +(define (zero? x) (= x 0)) +(define (positive? x) (> x 0)) +(define (negative? x) (< x 0)) + ;; syntax (define-syntax let diff --git a/sexp.c b/sexp.c index 6fa9cb3e..46597787 100644 --- a/sexp.c +++ b/sexp.c @@ -160,23 +160,11 @@ sexp sexp_append(sexp a, sexp b) { return b; } -sexp sexp_list(int count, ...) { - sexp res = SEXP_NULL; - int i; - va_list ap; - va_start(ap, count); - for (i=0; itag = SEXP_VECTOR; - v->data1 = (void*) len; + v->data1 = (void*) clen; v->data2 = (void*) x; return v; } @@ -289,7 +277,7 @@ sexp sexp_list_to_vector(sexp ls) { } sexp sexp_vector(int count, ...) { - sexp vec = sexp_make_vector(count, SEXP_UNDEF); + sexp vec = sexp_make_vector(sexp_make_integer(count), SEXP_UNDEF); sexp *elts = sexp_vector_data(vec); va_list ap; int i; @@ -593,6 +581,7 @@ sexp sexp_read_raw (sexp in) { /* ... FALLTHROUGH ... */ case ' ': case '\t': + case '\r': case '\n': goto scan_loop; case '\'': diff --git a/sexp.h b/sexp.h index 199be5c8..d8338949 100644 --- a/sexp.h +++ b/sexp.h @@ -225,15 +225,14 @@ sexp sexp_lset_diff(sexp a, sexp b); sexp sexp_reverse(sexp ls); sexp sexp_nreverse(sexp ls); sexp sexp_append(sexp a, sexp b); -sexp sexp_list(int count, ...); sexp sexp_memq(sexp x, sexp ls); sexp sexp_assq(sexp x, sexp ls); -unsigned long sexp_length(sexp ls); +sexp sexp_length(sexp ls); sexp sexp_make_string(char *str); sexp sexp_make_flonum(double f); int sexp_string_hash(char *str, int acc); sexp sexp_intern(char *str); -sexp sexp_make_vector(unsigned int len, sexp dflt); +sexp sexp_make_vector(sexp len, sexp dflt); sexp sexp_list_to_vector(sexp ls); sexp sexp_vector(int count, ...); void sexp_write(sexp obj, sexp out); diff --git a/tests/test00-fact-3.res b/tests/test00-fact-3.res new file mode 100644 index 00000000..f76d3d1e --- /dev/null +++ b/tests/test00-fact-3.res @@ -0,0 +1 @@ +(fact 3) => 6 diff --git a/tests/test00-fact-3.scm b/tests/test00-fact-3.scm new file mode 100644 index 00000000..46441893 --- /dev/null +++ b/tests/test00-fact-3.scm @@ -0,0 +1,14 @@ + +(define (fact-helper x res) + (if (zero? x) + res + (fact-helper (- x 1) (* res x)))) + +(define (fact x) + (fact-helper x 1)) + +(display "(fact 3) => ") +(write (fact 3)) +(newline) + + diff --git a/tests/test01-apply.res b/tests/test01-apply.res new file mode 100644 index 00000000..c5b83af4 --- /dev/null +++ b/tests/test01-apply.res @@ -0,0 +1,8 @@ +11 +(11 10 9 8 7 6 5 4 3 2 1) +(1 2 3 4) +100 +100 +100 +100 +100 diff --git a/tests/test01-apply.scm b/tests/test01-apply.scm new file mode 100644 index 00000000..183a591c --- /dev/null +++ b/tests/test01-apply.scm @@ -0,0 +1,18 @@ + +(define foo + (lambda (a b c d e f g h) + (+ (+ (* a b) (* c d)) (+ (* e f) (* g h))))) + +(define (writeln x) + (write x) + (newline)) + +(writeln (length (reverse (list 1 2 3 4 5 6 7 8 9 10 11)))) +(writeln (reverse (list 1 2 3 4 5 6 7 8 9 10 11))) +(writeln (append (list 1 2) (list 3 4))) +(writeln (foo 1 2 3 4 5 6 7 8)) +(writeln (apply foo (list 1 2 3 4 5 6 7 8))) +(writeln (apply foo 1 (list 2 3 4 5 6 7 8))) +(writeln (apply foo 1 2 3 4 (list 5 6 7 8))) +(writeln (apply foo 1 2 3 4 5 (list 6 7 8))) + diff --git a/tests/test02-callcc.res b/tests/test02-callcc.res new file mode 100644 index 00000000..849baeed --- /dev/null +++ b/tests/test02-callcc.res @@ -0,0 +1 @@ +543 diff --git a/tests/test02-callcc.scm b/tests/test02-callcc.scm new file mode 100644 index 00000000..3a5c355e --- /dev/null +++ b/tests/test02-callcc.scm @@ -0,0 +1,34 @@ + +(define fail + (lambda () 999999)) + +(define in-range + (lambda (a b) + (call-with-current-continuation + (lambda (cont) + (enumerate a b cont))))) + +(define enumerate + (lambda (a b cont) + (if (< b a) + (fail) + (let ((save fail)) + (begin + (set! fail + (lambda () + (begin + (set! fail save) + (enumerate (+ a 1) b cont)))) + (cont a)))))) + +(write + (let ((x (in-range 2 9)) + (y (in-range 2 9)) + (z (in-range 2 9))) + (if (= (* x x) + (+ (* y y) (* z z))) + (+ (* x 100) (+ (* y 10) z)) + (fail)))) + +(newline) + From 0cfa3c6242a5243e8bae9be57462032d88051a6d Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 15 Mar 2009 14:22:50 +0900 Subject: [PATCH 036/154] cleaning up some int types --- eval.c | 60 +++++++++++++++++++++++++++++----------------------------- eval.h | 20 ++++++++++---------- 2 files changed, 40 insertions(+), 40 deletions(-) diff --git a/eval.c b/eval.c index 674564b5..c24953cd 100644 --- a/eval.c +++ b/eval.c @@ -86,7 +86,7 @@ static sexp sexp_flatten_dot (sexp ls) { /************************* bytecode utilities ***************************/ -static void shrink_bcode(bytecode *bc, unsigned int i) { +static void shrink_bcode(bytecode *bc, sexp_uint_t i) { bytecode tmp; if ((*bc)->len != i) { /* fprintf(stderr, "shrinking to %d\n", i); */ @@ -99,11 +99,11 @@ static void shrink_bcode(bytecode *bc, unsigned int i) { } } -static void expand_bcode(bytecode *bc, unsigned int *i, unsigned int size) { +static void expand_bcode(bytecode *bc, sexp_uint_t *i, sexp_uint_t size) { bytecode tmp; if ((*bc)->len < (*i)+size) { fprintf(stderr, "expanding bytecode %u < %u + %u = %u\n", (*bc)->len, (*i), size, (*i)+size); - tmp = (bytecode) SEXP_ALLOC(sizeof(unsigned int) + (*bc)->len*2); + tmp = (bytecode) SEXP_ALLOC(sizeof(struct bytecode) + (*bc)->len*2); tmp->len = (*bc)->len*2; memcpy(tmp->data, (*bc)->data, (*bc)->len); SEXP_FREE(*bc); @@ -111,15 +111,15 @@ static void expand_bcode(bytecode *bc, unsigned int *i, unsigned int size) { } } -static void emit(bytecode *bc, unsigned int *i, char c) { +static void emit(bytecode *bc, sexp_uint_t *i, char c) { expand_bcode(bc, i, 1); (*bc)->data[(*i)++] = c; } -static void emit_word(bytecode *bc, unsigned int *i, sexp_uint_t val) { +static void emit_word(bytecode *bc, sexp_uint_t *i, sexp_uint_t val) { expand_bcode(bc, i, sizeof(sexp)); - *((unsigned long*)(&((*bc)->data[*i]))) = val; - *i += sizeof(unsigned long); + *((sexp_uint_t*)(&((*bc)->data[*i]))) = val; + *i += sizeof(sexp_uint_t); } #define emit_push(bc,i,obj) (emit(bc,i,OP_PUSH), \ @@ -149,7 +149,7 @@ static sexp sexp_make_macro (procedure p, env e) { sexp sexp_expand_macro (macro mac, sexp form, env e) { sexp res, *stack = SEXP_ALLOC(sizeof(sexp)*INIT_STACK_SIZE); bytecode bc; - unsigned int i=0; + sexp_uint_t i=0; fprintf(stderr, "expanding: "); sexp_write(form, cur_error_port); fprintf(stderr, "\n => "); @@ -172,8 +172,8 @@ sexp sexp_expand_macro (macro mac, sexp form, env e) { return res; } -void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, - sexp params, sexp fv, sexp sv, unsigned int *d, int tailp) { +void analyze(sexp obj, bytecode *bc, sexp_uint_t *i, env e, + sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp) { int tmp1, tmp2, tmp3; env e2; sexp o1, o2, cell; @@ -315,8 +315,8 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, } } -void analyze_opcode (opcode op, sexp obj, bytecode *bc, unsigned int *i, env e, - sexp params, sexp fv, sexp sv, unsigned int *d, int tailp) +void analyze_opcode (opcode op, sexp obj, bytecode *bc, sexp_uint_t *i, env e, + sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp) { int tmp1; sexp o1; @@ -385,8 +385,8 @@ void analyze_opcode (opcode op, sexp obj, bytecode *bc, unsigned int *i, env e, } } -void analyze_var_ref (sexp obj, bytecode *bc, unsigned int *i, env e, - sexp params, sexp fv, sexp sv, unsigned int *d) { +void analyze_var_ref (sexp obj, bytecode *bc, sexp_uint_t *i, env e, + sexp params, sexp fv, sexp sv, sexp_uint_t *d) { int tmp; sexp o1; /* fprintf(stderr, "symbol lookup, param length: %d sv: ", length(params)); */ @@ -415,8 +415,8 @@ void analyze_var_ref (sexp obj, bytecode *bc, unsigned int *i, env e, } } -void analyze_app (sexp obj, bytecode *bc, unsigned int *i, env e, - sexp params, sexp fv, sexp sv, unsigned int *d, int tailp) { +void analyze_app (sexp obj, bytecode *bc, sexp_uint_t *i, env e, + sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp) { sexp o1; sexp_uint_t len = sexp_unbox_integer(sexp_length(SEXP_CDR(obj))); @@ -496,8 +496,8 @@ sexp set_vars (env e, sexp formals, sexp obj, sexp sv) { } void analyze_lambda (sexp name, sexp formals, sexp body, - bytecode *bc, unsigned int *i, env e, - sexp params, sexp fv, sexp sv, unsigned int *d, + bytecode *bc, sexp_uint_t *i, env e, + sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp) { sexp obj, ls, flat_formals, fv2; env e2; @@ -544,7 +544,7 @@ sexp make_param_list(sexp_uint_t i) { sexp make_opcode_procedure(opcode op, sexp_uint_t i, env e) { bytecode bc = (bytecode) SEXP_ALLOC(sizeof(struct bytecode)+INIT_BCODE_SIZE); sexp params = make_param_list(i); - unsigned int pos=0, d=0; + sexp_uint_t pos=0, d=0; e = extend_env_closure(e, params, -4); bc->tag = SEXP_BYTECODE; bc->len = INIT_BCODE_SIZE; @@ -558,7 +558,7 @@ sexp make_opcode_procedure(opcode op, sexp_uint_t i, env e) { } bytecode compile(sexp params, sexp obj, env e, sexp fv, sexp sv, int done_p) { - unsigned int i = 0, j, d = 0, core, define_ok=1; + sexp_uint_t i = 0, j, d = 0, core, define_ok=1; bytecode bc = (bytecode) SEXP_ALLOC(sizeof(struct bytecode)+INIT_BCODE_SIZE); sexp sv2 = set_vars(e, params, obj, SEXP_NULL), internals=SEXP_NULL, ls; bc->tag = SEXP_BYTECODE; @@ -637,9 +637,9 @@ bytecode compile(sexp params, sexp obj, env e, sexp fv, sexp sv, int done_p) { /*********************** the virtual machine **************************/ -sexp sexp_save_stack(sexp *stack, unsigned int to) { +sexp sexp_save_stack(sexp *stack, sexp_uint_t to) { sexp res, *data; - int i; + sexp_uint_t i; res = sexp_make_vector(sexp_make_integer(to), SEXP_UNDEF); data = sexp_vector_data(res); for (i=0; idata; sexp cp=SEXP_UNDEF, tmp1, tmp2; - int i, j, k; + sexp_sint_t i, j, k; loop: print_stack(stack, top); @@ -1187,7 +1187,7 @@ _PARAM("interaction-environment", (sexp)&interaction_environment, SEXP_ENV), }; env make_standard_env() { - int i; + sexp_uint_t i; env e = (env) SEXP_ALLOC(sizeof(struct env)); e->tag = SEXP_ENV; e->parent = NULL; @@ -1201,7 +1201,7 @@ env make_standard_env() { /************************** eval interface ****************************/ -sexp eval_in_stack(sexp obj, env e, sexp* stack, unsigned int top) { +sexp eval_in_stack(sexp obj, env e, sexp* stack, sexp_sint_t top) { bytecode bc; bc = compile(SEXP_NULL, sexp_cons(obj, SEXP_NULL), e, SEXP_NULL, SEXP_NULL, 1); return vm(bc, e, stack, top); @@ -1216,7 +1216,7 @@ sexp eval(sexp obj, env e) { void scheme_init() { bytecode bc; - unsigned int i=0; + sexp_uint_t i=0; if (! scheme_initialized_p) { scheme_initialized_p = 1; sexp_init(); @@ -1251,7 +1251,7 @@ int main (int argc, char **argv) { sexp obj, res, in, out, *stack, err_handler, err_handler_sym; env e; bytecode bc; - unsigned int i, quit=0, init_loaded=0; + sexp_uint_t i, quit=0, init_loaded=0; FILE *stream; scheme_init(); diff --git a/eval.h b/eval.h index f4204a8d..60152ca3 100644 --- a/eval.h +++ b/eval.h @@ -174,19 +174,19 @@ enum opcode_names { bytecode compile(sexp params, sexp obj, env e, sexp fv, sexp sv, int done_p); -void analyze_app (sexp obj, bytecode *bc, unsigned int *i, +void analyze_app (sexp obj, bytecode *bc, sexp_uint_t *i, env e, sexp params, sexp fv, sexp sv, - unsigned int *d, int tailp); + sexp_uint_t *d, int tailp); void analyze_lambda (sexp name, sexp formals, sexp body, - bytecode *bc, unsigned int *i, env e, - sexp params, sexp fv, sexp sv, unsigned int *d, int tailp); -void analyze_var_ref (sexp name, bytecode *bc, unsigned int *i, env e, - sexp params, sexp fv, sexp sv, unsigned int *d); -void analyze_opcode (opcode op, sexp obj, bytecode *bc, unsigned int *i, env e, - sexp params, sexp fv, sexp sv, unsigned int *d, int tailp); -sexp vm(bytecode bc, env e, sexp* stack, unsigned int top); + bytecode *bc, sexp_uint_t *i, env e, + sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp); +void analyze_var_ref (sexp name, bytecode *bc, sexp_uint_t *i, env e, + sexp params, sexp fv, sexp sv, sexp_uint_t *d); +void analyze_opcode (opcode op, sexp obj, bytecode *bc, sexp_uint_t *i, env e, + sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp); +sexp vm(bytecode bc, env e, sexp* stack, sexp_sint_t top); -sexp eval_in_stack(sexp obj, env e, sexp* stack, unsigned int top); +sexp eval_in_stack(sexp obj, env e, sexp* stack, sexp_sint_t top); sexp eval(sexp obj, env e); #endif /* ! SEXP_EVAL_H */ From 4bc491c946e10eb2e5fa3d31bb7b8a6aa0c93070 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 15 Mar 2009 17:42:28 +0900 Subject: [PATCH 037/154] minor bugfixes --- eval.c | 48 +++++++++++++++++++++++++----------------------- 1 file changed, 25 insertions(+), 23 deletions(-) diff --git a/eval.c b/eval.c index c24953cd..8916998c 100644 --- a/eval.c +++ b/eval.c @@ -226,14 +226,21 @@ void analyze(sexp obj, bytecode *bc, sexp_uint_t *i, env e, break; case CORE_SET: analyze(SEXP_CADDR(obj), bc, i, e, params, fv, sv, d, 0); - analyze_var_ref(SEXP_CADR(obj), bc, i, e, params, fv, SEXP_NULL, d); - emit(bc, i, OP_SET_CAR); + if (sexp_list_index(sv, SEXP_CADR(obj)) >= 0) { + analyze_var_ref(SEXP_CADR(obj), bc, i, e, params, fv, SEXP_NULL, d); + emit(bc, i, OP_SET_CAR); + } else { + emit(bc, i, OP_GLOBAL_SET); + emit_word(bc, i, (sexp_uint_t) SEXP_CADR(obj)); + emit_push(bc, i, SEXP_UNDEF); + } break; case CORE_BEGIN: for (o2 = SEXP_CDR(obj); SEXP_PAIRP(o2); o2 = SEXP_CDR(o2)) { if (SEXP_PAIRP(SEXP_CDR(o2))) { analyze(SEXP_CAR(o2), bc, i, e, params, fv, sv, d, 0); emit(bc, i, OP_DROP); + (*d)--; } else analyze(SEXP_CAR(o2), bc, i, e, params, fv, sv, d, tailp); } @@ -291,6 +298,7 @@ void analyze(sexp obj, bytecode *bc, sexp_uint_t *i, env e, if (SEXP_PAIRP(SEXP_CDR(o2))) { analyze(SEXP_CAR(o2), bc, i, e2, params, fv, sv, d, 0); emit(bc, i, OP_DROP); + (*d)--; } else { analyze(SEXP_CAR(o2), bc, i, e2, params, fv, sv, d, tailp); } @@ -342,16 +350,13 @@ void analyze_opcode (opcode op, sexp obj, bytecode *bc, sexp_uint_t *i, env e, emit(bc, i, op->op_name); } } else { - for (o1 = sexp_reverse(SEXP_CDR(obj)); SEXP_PAIRP(o1); - o1 = SEXP_CDR(o1)) { + for (o1=sexp_reverse(SEXP_CDR(obj)); SEXP_PAIRP(o1); o1=SEXP_CDR(o1)) analyze(SEXP_CAR(o1), bc, i, e, params, fv, sv, d, 0); - } emit(bc, i, op->op_name); (*d) -= (tmp1-1); - if (op->op_class == OPC_ARITHMETIC) { + if (op->op_class == OPC_ARITHMETIC) for (tmp1-=2; tmp1>0; tmp1--) emit(bc, i, op->op_name); - } } break; case OPC_IO: @@ -362,8 +367,7 @@ void analyze_opcode (opcode op, sexp obj, bytecode *bc, sexp_uint_t *i, env e, (*d)++; tmp1++; } - for (o1 = sexp_reverse(SEXP_CDR(obj)); SEXP_PAIRP(o1); - o1 = SEXP_CDR(o1)) + for (o1=sexp_reverse(SEXP_CDR(obj)); SEXP_PAIRP(o1); o1=SEXP_CDR(o1)) analyze(SEXP_CAR(o1), bc, i, e, params, fv, sv, d, 0); emit(bc, i, op->op_name); (*d) -= (tmp1-1); @@ -373,9 +377,8 @@ void analyze_opcode (opcode op, sexp obj, bytecode *bc, sexp_uint_t *i, env e, emit_word(bc, i, (sexp_uint_t) op->data); break; case OPC_FOREIGN: - for (o1=sexp_reverse(SEXP_CDR(obj)); SEXP_PAIRP(o1); o1=SEXP_CDR(o1)) { + for (o1=sexp_reverse(SEXP_CDR(obj)); SEXP_PAIRP(o1); o1=SEXP_CDR(o1)) analyze(SEXP_CAR(o1), bc, i, e, params, fv, sv, d, 0); - } emit_push(bc, i, op->data); emit(bc, i, op->op_name); (*d) -= (sexp_unbox_integer(sexp_length(SEXP_CDR(obj)))-1); @@ -563,6 +566,7 @@ bytecode compile(sexp params, sexp obj, env e, sexp fv, sexp sv, int done_p) { sexp sv2 = set_vars(e, params, obj, SEXP_NULL), internals=SEXP_NULL, ls; bc->tag = SEXP_BYTECODE; bc->len = INIT_BCODE_SIZE; + sexp_debug("set-vars: ", sv2); /* box mutable vars */ for (ls=params; SEXP_PAIRP(ls); ls=SEXP_CDR(ls)) { if ((j = sexp_list_index(sv2, SEXP_CAR(ls)) >= 0)) { @@ -663,8 +667,8 @@ sexp vm(bytecode bc, env e, sexp* stack, sexp_sint_t top) { sexp_sint_t i, j, k; loop: - print_stack(stack, top); - fprintf(stderr, "OP: %s (%d)\n", (*ip<=71) ? reverse_opcode_names[*ip] : "", *ip); +/* print_stack(stack, top); */ +/* fprintf(stderr, "OP: %s (%d)\n", (*ip<=71) ? reverse_opcode_names[*ip] : "", *ip); */ switch (*ip++) { case OP_NOOP: fprintf(stderr, "noop\n"); @@ -809,31 +813,31 @@ sexp vm(bytecode bc, env e, sexp* stack, sexp_sint_t top) { top--; break; case OP_MUL: - stack[top-2]=sexp_mul(stack[top-2],stack[top-1]); + stack[top-2]=sexp_mul(stack[top-1],stack[top-2]); top--; break; case OP_DIV: - stack[top-2]=sexp_div(stack[top-2],stack[top-1]); + stack[top-2]=sexp_div(stack[top-1],stack[top-2]); top--; break; case OP_MOD: - stack[top-2]=sexp_mod(stack[top-2],stack[top-1]); + stack[top-2]=sexp_mod(stack[top-1],stack[top-2]); top--; break; case OP_LT: - stack[top-2]=((stack[top-2] < stack[top-1]) ? SEXP_TRUE : SEXP_FALSE); + stack[top-2]=((stack[top-1] < stack[top-2]) ? SEXP_TRUE : SEXP_FALSE); top--; break; case OP_LE: - stack[top-2]=((stack[top-2] <= stack[top-1]) ? SEXP_TRUE : SEXP_FALSE); + stack[top-2]=((stack[top-1] <= stack[top-2]) ? SEXP_TRUE : SEXP_FALSE); top--; break; case OP_GT: - stack[top-2]=((stack[top-2] > stack[top-1]) ? SEXP_TRUE : SEXP_FALSE); + stack[top-2]=((stack[top-1] > stack[top-2]) ? SEXP_TRUE : SEXP_FALSE); top--; break; case OP_GE: - stack[top-2]=((stack[top-2] >= stack[top-1]) ? SEXP_TRUE : SEXP_FALSE); + stack[top-2]=((stack[top-1] >= stack[top-2]) ? SEXP_TRUE : SEXP_FALSE); top--; break; case OP_EQ: @@ -939,11 +943,9 @@ sexp vm(bytecode bc, env e, sexp* stack, sexp_sint_t top) { /* fprintf(stderr, "saved: ", top); */ /* sexp_write(tmp2, cur_error_port); */ /* fprintf(stderr, "\n", top); */ - tmp2 = sexp_make_vector(sexp_make_integer(1), SEXP_UNDEF); - sexp_vector_set(tmp2, sexp_make_integer(1), sexp_save_stack(stack, top+3)); stack[top-1] = sexp_make_procedure(0, (int) sexp_make_integer(1), continuation_resumer, - tmp2); + sexp_vector(1, sexp_save_stack(stack, top+3))); top+=3; bc = sexp_procedure_code(tmp1); ip = bc->data; From caa9a104dda0d207354cda2da4a0da68338eee7f Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 15 Mar 2009 20:59:35 +0900 Subject: [PATCH 038/154] cleaning up types - using a single union for all heap allocated types --- Makefile | 2 +- debug.c | 27 ++-- eval.c | 390 ++++++++++++++++++++++++++++--------------------------- eval.h | 65 ++-------- sexp.c | 56 ++++---- sexp.h | 196 ++++++++++++++++++++-------- 6 files changed, 401 insertions(+), 335 deletions(-) diff --git a/Makefile b/Makefile index f3ce3824..c4228672 100644 --- a/Makefile +++ b/Makefile @@ -30,7 +30,7 @@ cleaner: clean rm -rf *.dSYM test: chibi-scheme - for f in tests/*.scm; do \ + @for f in tests/*.scm; do \ ./chibi-scheme $$f >$${f%.scm}.out 2>$${f%.scm}.err; \ if diff -q $${f%.scm}.out $${f%.scm}.res; then \ echo "[PASS] $${f%.scm}"; \ diff --git a/debug.c b/debug.c index 391f456e..7526fa13 100644 --- a/debug.c +++ b/debug.c @@ -17,8 +17,8 @@ static const char* reverse_opcode_names[] = "READ-CHAR", }; -void disasm (bytecode bc) { - unsigned char *ip=bc->data, opcode; +void disasm (sexp bc) { + unsigned char *ip=sexp_bytecode_data(bc), opcode; loop: opcode = *ip++; if (opcode*sizeof(char*) < sizeof(reverse_opcode_names)) { @@ -55,29 +55,30 @@ void disasm (bytecode bc) { } fprintf(stderr, "\n"); if ((! (opcode == OP_RET) || (opcode == OP_DONE)) - && (ip - bc->data < bc->len)) + && (ip - sexp_bytecode_data(bc) < sexp_bytecode_length(bc))) goto loop; } -void print_bytecode (bytecode bc) { +void print_bytecode (sexp bc) { int i; + unsigned char *data = sexp_bytecode_data(bc); fprintf(stderr, "bytecode @ %p, data @ %p, length = %d\n", - bc, bc->data, bc->len); - for (i=0; i+16 < bc->len; i+=8) { + bc, data, sexp_bytecode_length(bc)); + for (i=0; i+16 < sexp_bytecode_length(bc); i+=8) { fprintf(stderr, "%02x: %02x %02x %02x %02x %02x %02x %02x %02x ", i, - bc->data[i], bc->data[i+1], bc->data[i+2], bc->data[i+3], - bc->data[i+4], bc->data[i+5], bc->data[i+6], bc->data[i+7]); + data[i], data[i+1], data[i+2], data[i+3], + data[i+4], data[i+5], data[i+6], data[i+7]); i += 8; fprintf(stderr, "%02x %02x %02x %02x %02x %02x %02x %02x\n", - bc->data[i], bc->data[i+1], bc->data[i+2], bc->data[i+3], - bc->data[i+4], bc->data[i+5], bc->data[i+6], bc->data[i+7]); + data[i], data[i+1], data[i+2], data[i+3], + data[i+4], data[i+5], data[i+6], data[i+7]); } - if (i != bc->len) { + if (i != sexp_bytecode_length(bc)) { fprintf(stderr, "%02x:", i); - for ( ; i < bc->len; i++) { + for ( ; i < sexp_bytecode_length(bc); i++) { if ((i % 8) == 0 && (i % 16) != 0) fprintf(stderr, " "); - fprintf(stderr, " %02x", bc->data[i]); + fprintf(stderr, " %02x", data[i]); } fprintf(stderr, "\n"); } diff --git a/eval.c b/eval.c index 8916998c..b89f79af 100644 --- a/eval.c +++ b/eval.c @@ -23,54 +23,56 @@ static sexp interaction_environment; /********************** environment utilities ***************************/ -static sexp env_cell(env e, sexp key) { +static sexp env_cell(sexp e, sexp key) { sexp ls; do { - for (ls=e->bindings; SEXP_PAIRP(ls); ls=SEXP_CDR(ls)) + for (ls=sexp_env_bindings(e); SEXP_PAIRP(ls); ls=SEXP_CDR(ls)) if (SEXP_CAAR(ls) == key) return SEXP_CAR(ls); - e = e->parent; + e = sexp_env_parent(e); } while (e); return NULL; } -static int env_global_p (env e, sexp id) { - while (e->parent) { - if (sexp_assq(id, e->bindings) != SEXP_FALSE) +static int env_global_p (sexp e, sexp id) { + while (sexp_env_parent(e)) { + if (sexp_assq(id, sexp_env_bindings(e)) != SEXP_FALSE) return 0; else - e = e->parent; + e = sexp_env_parent(e); } return 1; } -static void env_define(env e, sexp key, sexp value) { +static void env_define(sexp e, sexp key, sexp value) { sexp cell = env_cell(e, key); if (cell) { SEXP_CDR(cell) = value; } else { - e->bindings = sexp_cons(sexp_cons(key, value), e->bindings); + sexp_env_bindings(e) + = sexp_cons(sexp_cons(key, value), sexp_env_bindings(e)); } } -static env extend_env_closure (env e, sexp fv, int offset) { +static sexp extend_env_closure (sexp e, sexp fv, int offset) { int i; - env e2 = (env) SEXP_ALLOC(sizeof(struct env)); + sexp e2 = (sexp) SEXP_ALLOC(sexp_sizeof(env)); e2->tag = SEXP_ENV; - e2->parent = e; - e2->bindings = SEXP_NULL; + sexp_env_parent(e2) = e; + sexp_env_bindings(e2) = SEXP_NULL; for (i=offset; SEXP_PAIRP(fv); fv = SEXP_CDR(fv), i--) - e2->bindings = sexp_cons(sexp_cons(SEXP_CAR(fv), sexp_make_integer(i)), - e2->bindings); + sexp_env_bindings(e2) + = sexp_cons(sexp_cons(SEXP_CAR(fv), sexp_make_integer(i)), + sexp_env_bindings(e2)); return e2; } -static int core_code (env e, sexp sym) { +static int core_code (sexp e, sexp sym) { sexp cell = env_cell(e, sym); if (! cell || ! SEXP_COREP(SEXP_CDR(cell))) return 0; - return (((core_form)SEXP_CDR(cell))->code); + return (sexp_core_code(SEXP_CDR(cell))); } static sexp sexp_reverse_flatten_dot (sexp ls) { @@ -86,39 +88,41 @@ static sexp sexp_flatten_dot (sexp ls) { /************************* bytecode utilities ***************************/ -static void shrink_bcode(bytecode *bc, sexp_uint_t i) { - bytecode tmp; - if ((*bc)->len != i) { - /* fprintf(stderr, "shrinking to %d\n", i); */ - tmp = (bytecode) SEXP_ALLOC(sizeof(struct bytecode) + i); +static void shrink_bcode(sexp *bc, sexp_uint_t i) { + sexp tmp; + if (sexp_bytecode_length(*bc) != i) { + tmp = (sexp) SEXP_ALLOC(sexp_sizeof(bytecode) + i); tmp->tag = SEXP_BYTECODE; - tmp->len = i; - memcpy(tmp->data, (*bc)->data, i); + sexp_bytecode_length(tmp) = i; + memcpy(sexp_bytecode_data(tmp), sexp_bytecode_data(*bc), i); SEXP_FREE(*bc); *bc = tmp; } } -static void expand_bcode(bytecode *bc, sexp_uint_t *i, sexp_uint_t size) { - bytecode tmp; - if ((*bc)->len < (*i)+size) { - fprintf(stderr, "expanding bytecode %u < %u + %u = %u\n", (*bc)->len, (*i), size, (*i)+size); - tmp = (bytecode) SEXP_ALLOC(sizeof(struct bytecode) + (*bc)->len*2); - tmp->len = (*bc)->len*2; - memcpy(tmp->data, (*bc)->data, (*bc)->len); +static void expand_bcode(sexp *bc, sexp_uint_t *i, sexp_uint_t size) { + sexp tmp; + if (sexp_bytecode_length(*bc) < (*i)+size) { + tmp = (sexp) SEXP_ALLOC(sexp_sizeof(bytecode) + + sexp_bytecode_length(*bc)*2); + tmp->tag = SEXP_BYTECODE; + sexp_bytecode_length(tmp) = sexp_bytecode_length(*bc)*2; + memcpy(sexp_bytecode_data(tmp), + sexp_bytecode_data(*bc), + sexp_bytecode_length(*bc)); SEXP_FREE(*bc); *bc = tmp; } } -static void emit(bytecode *bc, sexp_uint_t *i, char c) { +static void emit(sexp *bc, sexp_uint_t *i, char c) { expand_bcode(bc, i, 1); - (*bc)->data[(*i)++] = c; + sexp_bytecode_data(*bc)[(*i)++] = c; } -static void emit_word(bytecode *bc, sexp_uint_t *i, sexp_uint_t val) { +static void emit_word(sexp *bc, sexp_uint_t *i, sexp_uint_t val) { expand_bcode(bc, i, sizeof(sexp)); - *((sexp_uint_t*)(&((*bc)->data[*i]))) = val; + *((sexp_uint_t*)(&(sexp_bytecode_data(*bc)[*i]))) = val; *i += sizeof(sexp_uint_t); } @@ -127,43 +131,41 @@ static void emit_word(bytecode *bc, sexp_uint_t *i, sexp_uint_t val) { static sexp sexp_make_procedure(char flags, unsigned short num_args, sexp bc, sexp vars) { - procedure proc = SEXP_ALLOC(sizeof(struct procedure)); + sexp proc = (sexp) SEXP_ALLOC(sexp_sizeof(procedure)); proc->tag = SEXP_PROCEDURE; - proc->flags = flags; - proc->num_args = num_args; - proc->bc = (bytecode) bc; - proc->vars = vars; - return (sexp) proc; + sexp_procedure_flags(proc) = flags; + sexp_procedure_num_args(proc) = num_args; + sexp_procedure_code(proc) = bc; + sexp_procedure_vars(proc) = vars; + return proc; } -static sexp sexp_make_macro (procedure p, env e) { - macro mac = SEXP_ALLOC(sizeof(struct macro)); +static sexp sexp_make_macro (sexp p, sexp e) { + sexp mac = (sexp) SEXP_ALLOC(sexp_sizeof(macro)); mac->tag = SEXP_MACRO; - mac->e = e; - mac->proc = p; - return (sexp) mac; + sexp_macro_env(mac) = e; + sexp_macro_proc(mac) = p; + return mac; } /************************* the compiler ***************************/ -sexp sexp_expand_macro (macro mac, sexp form, env e) { - sexp res, *stack = SEXP_ALLOC(sizeof(sexp)*INIT_STACK_SIZE); - bytecode bc; +sexp sexp_expand_macro (sexp mac, sexp form, sexp e) { + sexp bc, res, *stack = SEXP_ALLOC(sizeof(sexp)*INIT_STACK_SIZE); sexp_uint_t i=0; fprintf(stderr, "expanding: "); sexp_write(form, cur_error_port); fprintf(stderr, "\n => "); - bc = (bytecode) SEXP_ALLOC(sizeof(struct bytecode)+64); + bc = (sexp) SEXP_ALLOC(sexp_sizeof(bytecode)+64); bc->tag = SEXP_BYTECODE; - bc->len = 32; - emit_push(&bc, &i, mac->e); + sexp_bytecode_length(bc) = 32; + emit_push(&bc, &i, sexp_macro_env(mac)); emit_push(&bc, &i, e); emit_push(&bc, &i, form); - emit_push(&bc, &i, mac->proc); + emit_push(&bc, &i, sexp_macro_proc(mac)); emit(&bc, &i, OP_CALL); emit_word(&bc, &i, (sexp_uint_t) sexp_make_integer(3)); emit(&bc, &i, OP_DONE); - /* disasm(bc); */ res = vm(bc, e, stack, 0); sexp_write(res, cur_error_port); fprintf(stderr, "\n"); @@ -172,11 +174,10 @@ sexp sexp_expand_macro (macro mac, sexp form, env e) { return res; } -void analyze(sexp obj, bytecode *bc, sexp_uint_t *i, env e, +void analyze(sexp obj, sexp *bc, sexp_uint_t *i, sexp e, sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp) { int tmp1, tmp2, tmp3; - env e2; - sexp o1, o2, cell; + sexp o1, o2, e2, cell; loop: if (SEXP_PAIRP(obj)) { @@ -188,19 +189,19 @@ void analyze(sexp obj, bytecode *bc, sexp_uint_t *i, env e, } o1 = SEXP_CDR(o1); if (SEXP_COREP(o1)) { - switch (((core_form)o1)->code) { + switch (sexp_core_code(o1)) { case CORE_LAMBDA: analyze_lambda(SEXP_FALSE, SEXP_CADR(obj), SEXP_CDDR(obj), bc, i, e, params, fv, sv, d, tailp); break; case CORE_DEFINE_SYNTAX: env_define(e, SEXP_CADR(obj), - sexp_make_macro((procedure) eval(SEXP_CADDR(obj), e), e)); + sexp_make_macro(eval(SEXP_CADDR(obj), e), e)); emit_push(bc, i, SEXP_UNDEF); (*d)++; break; case CORE_DEFINE: - if ((((core_form)o1)->code == CORE_DEFINE) + if ((sexp_core_code(o1) == CORE_DEFINE) && SEXP_PAIRP(SEXP_CADR(obj))) { o2 = SEXP_CAR(SEXP_CADR(obj)); analyze_lambda(SEXP_CAR(SEXP_CADR(obj)), @@ -211,7 +212,7 @@ void analyze(sexp obj, bytecode *bc, sexp_uint_t *i, env e, o2 = SEXP_CADR(obj); analyze(SEXP_CADDR(obj), bc, i, e, params, fv, sv, d, 0); } - if (! e->parent) { + if (sexp_env_global_p(e)) { emit(bc, i, OP_GLOBAL_SET); emit_word(bc, i, (sexp_uint_t) o2); emit_push(bc, i, SEXP_UNDEF); @@ -256,26 +257,28 @@ void analyze(sexp obj, bytecode *bc, sexp_uint_t *i, env e, (*d)--; tmp2 = *i; emit(bc, i, 0); - ((signed char*) (*bc)->data)[tmp1] = (*i)-tmp1; /* patch */ + /* ((signed char*) (*bc)->data)[tmp1] = (*i)-tmp1; /\* patch *\/ */ + ((signed char*) sexp_bytecode_data(*bc))[tmp1] = (*i)-tmp1; if (SEXP_PAIRP(SEXP_CDDDR(obj))) { analyze(SEXP_CADDDR(obj), bc, i, e, params, fv, sv, d, tailp); } else { emit_push(bc, i, SEXP_UNDEF); (*d)++; } - ((signed char*) (*bc)->data)[tmp2] = (*i)-tmp2; /* patch */ + /* ((signed char*) (*bc)->data)[tmp2] = (*i)-tmp2; /\* patch *\/ */ + ((signed char*) sexp_bytecode_data(*bc))[tmp2] = (*i)-tmp2; break; case CORE_QUOTE: emit_push(bc, i, SEXP_CADR(obj)); (*d)++; break; default: - errx(1, "unknown core form: %s", ((core_form)o1)->code); + errx(1, "unknown core form: %s", sexp_core_code(o1)); } } else if (SEXP_OPCODEP(o1)) { - analyze_opcode((opcode)o1, obj, bc, i, e, params, fv, sv, d, tailp); + analyze_opcode(o1, obj, bc, i, e, params, fv, sv, d, tailp); } else if (SEXP_MACROP(o1)) { - obj = sexp_expand_macro((macro) o1, obj, e); + obj = sexp_expand_macro(o1, obj, e); goto loop; } else { /* general procedure call */ @@ -286,7 +289,7 @@ void analyze(sexp obj, bytecode *bc, sexp_uint_t *i, env e, o2 = env_cell(e, SEXP_CAAR(obj)); if (o2 && SEXP_COREP(SEXP_CDR(o2)) - && (((core_form)SEXP_CDR(o2))->code == CORE_LAMBDA) + && (sexp_core_code(o2) == CORE_LAMBDA) && sexp_listp(SEXP_CADR(SEXP_CAR(obj)))) { /* let */ tmp1 = sexp_unbox_integer(sexp_length(SEXP_CADR(SEXP_CAR(obj)))); @@ -323,13 +326,13 @@ void analyze(sexp obj, bytecode *bc, sexp_uint_t *i, env e, } } -void analyze_opcode (opcode op, sexp obj, bytecode *bc, sexp_uint_t *i, env e, +void analyze_opcode (sexp op, sexp obj, sexp *bc, sexp_uint_t *i, sexp e, sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp) { int tmp1; sexp o1; - switch (op->op_class) { + switch (sexp_opcode_class(op)) { case OPC_TYPE_PREDICATE: case OPC_PREDICATE: case OPC_ARITHMETIC: @@ -340,55 +343,55 @@ void analyze_opcode (opcode op, sexp obj, bytecode *bc, sexp_uint_t *i, env e, case OPC_GENERIC: tmp1 = sexp_unbox_integer(sexp_length(SEXP_CDR(obj))); if (tmp1 == 0) { - errx(1, "opcode with no arguments: %s", op->name); + errx(1, "opcode with no arguments: %s", sexp_opcode_name(op)); } else if (tmp1 == 1) { analyze(SEXP_CADR(obj), bc, i, e, params, fv, sv, d, 0); - if (op->op_class == OPC_ARITHMETIC_INV) { - emit(bc, i, op->op_inverse); + if (sexp_opcode_class(op) == OPC_ARITHMETIC_INV) { + emit(bc, i, sexp_opcode_inverse(op)); (*d)++; - } else if (op->op_class != OPC_ARITHMETIC) { - emit(bc, i, op->op_name); + } else if (sexp_opcode_class(op) != OPC_ARITHMETIC) { + emit(bc, i, sexp_opcode_code(op)); } } else { for (o1=sexp_reverse(SEXP_CDR(obj)); SEXP_PAIRP(o1); o1=SEXP_CDR(o1)) analyze(SEXP_CAR(o1), bc, i, e, params, fv, sv, d, 0); - emit(bc, i, op->op_name); + emit(bc, i, sexp_opcode_code(op)); (*d) -= (tmp1-1); - if (op->op_class == OPC_ARITHMETIC) + if (sexp_opcode_class(op) == OPC_ARITHMETIC) for (tmp1-=2; tmp1>0; tmp1--) - emit(bc, i, op->op_name); + emit(bc, i, sexp_opcode_code(op)); } break; case OPC_IO: tmp1 = sexp_unbox_integer(sexp_length(SEXP_CDR(obj))); - if (tmp1 == op->num_args && op->var_args_p) { + if (tmp1 == sexp_opcode_num_args(op) && sexp_opcode_variadic_p(op)) { emit(bc, i, OP_PARAMETER); - emit_word(bc, i, (sexp_uint_t) op->data); + emit_word(bc, i, (sexp_uint_t) sexp_opcode_data(op)); (*d)++; tmp1++; } for (o1=sexp_reverse(SEXP_CDR(obj)); SEXP_PAIRP(o1); o1=SEXP_CDR(o1)) analyze(SEXP_CAR(o1), bc, i, e, params, fv, sv, d, 0); - emit(bc, i, op->op_name); + emit(bc, i, sexp_opcode_code(op)); (*d) -= (tmp1-1); break; case OPC_PARAMETER: - emit(bc, i, op->op_name); - emit_word(bc, i, (sexp_uint_t) op->data); + emit(bc, i, sexp_opcode_code(op)); + emit_word(bc, i, (sexp_uint_t) sexp_opcode_data(op)); break; case OPC_FOREIGN: for (o1=sexp_reverse(SEXP_CDR(obj)); SEXP_PAIRP(o1); o1=SEXP_CDR(o1)) analyze(SEXP_CAR(o1), bc, i, e, params, fv, sv, d, 0); - emit_push(bc, i, op->data); - emit(bc, i, op->op_name); + emit_push(bc, i, sexp_opcode_data(op)); + emit(bc, i, sexp_opcode_code(op)); (*d) -= (sexp_unbox_integer(sexp_length(SEXP_CDR(obj)))-1); break; default: - errx(1, "unknown opcode class: %d", op->op_class); + errx(1, "unknown opcode class: %d", sexp_opcode_class(op)); } } -void analyze_var_ref (sexp obj, bytecode *bc, sexp_uint_t *i, env e, +void analyze_var_ref (sexp obj, sexp *bc, sexp_uint_t *i, sexp e, sexp params, sexp fv, sexp sv, sexp_uint_t *d) { int tmp; sexp o1; @@ -418,7 +421,7 @@ void analyze_var_ref (sexp obj, bytecode *bc, sexp_uint_t *i, env e, } } -void analyze_app (sexp obj, bytecode *bc, sexp_uint_t *i, env e, +void analyze_app (sexp obj, sexp *bc, sexp_uint_t *i, sexp e, sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp) { sexp o1; sexp_uint_t len = sexp_unbox_integer(sexp_length(SEXP_CDR(obj))); @@ -445,7 +448,7 @@ void analyze_app (sexp obj, bytecode *bc, sexp_uint_t *i, env e, (*d) -= (len); } -sexp free_vars (env e, sexp formals, sexp obj, sexp fv) { +sexp free_vars (sexp e, sexp formals, sexp obj, sexp fv) { sexp o1; if (SEXP_SYMBOLP(obj)) { if (env_global_p(e, obj) @@ -458,7 +461,7 @@ sexp free_vars (env e, sexp formals, sexp obj, sexp fv) { if (SEXP_SYMBOLP(SEXP_CAR(obj))) { if ((o1 = env_cell(e, SEXP_CAR(obj))) && SEXP_COREP(o1) - && (((core_form)SEXP_CDR(o1))->code == CORE_LAMBDA)) { + && (sexp_core_code(SEXP_CDR(o1)) == CORE_LAMBDA)) { return free_vars(e, SEXP_CADR(obj), SEXP_CADDR(obj), fv); } } @@ -472,17 +475,17 @@ sexp free_vars (env e, sexp formals, sexp obj, sexp fv) { } } -sexp set_vars (env e, sexp formals, sexp obj, sexp sv) { +sexp set_vars (sexp e, sexp formals, sexp obj, sexp sv) { sexp tmp; if (SEXP_NULLP(formals)) return sv; if (SEXP_PAIRP(obj)) { if (SEXP_SYMBOLP(SEXP_CAR(obj))) { if ((tmp = env_cell(e, SEXP_CAR(obj))) && SEXP_COREP(SEXP_CDR(tmp))) { - if (((core_form)SEXP_CDR(tmp))->code == CORE_LAMBDA) { + if (sexp_core_code(SEXP_CDR(tmp)) == CORE_LAMBDA) { formals = sexp_lset_diff(formals, SEXP_CADR(obj)); return set_vars(e, formals, SEXP_CADDR(obj), sv); - } else if (((core_form)SEXP_CDR(tmp))->code == CORE_SET + } else if (sexp_core_code(SEXP_CDR(tmp)) == CORE_SET && (sexp_list_index(formals, SEXP_CADR(obj)) >= 0) && ! (sexp_list_index(sv, SEXP_CADR(obj)) >= 0)) { sv = sexp_cons(SEXP_CADR(obj), sv); @@ -499,11 +502,10 @@ sexp set_vars (env e, sexp formals, sexp obj, sexp sv) { } void analyze_lambda (sexp name, sexp formals, sexp body, - bytecode *bc, sexp_uint_t *i, env e, + sexp *bc, sexp_uint_t *i, sexp e, sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp) { - sexp obj, ls, flat_formals, fv2; - env e2; + sexp obj, ls, flat_formals, fv2, e2; int k; flat_formals = sexp_flatten_dot(formals); fv2 = free_vars(e, flat_formals, body, SEXP_NULL); @@ -512,7 +514,7 @@ void analyze_lambda (sexp name, sexp formals, sexp body, /* sexp_write(fv2, cur_error_port); */ /* fprintf(stderr, "\n"); */ /* compile the body with respect to the new params */ - obj = (sexp) compile(flat_formals, body, e2, fv2, sv, 0); + obj = compile(flat_formals, body, e2, fv2, sv, 0); /* push the closed vars */ emit_push(bc, i, SEXP_UNDEF); emit_push(bc, i, sexp_length(fv2)); @@ -544,28 +546,33 @@ sexp make_param_list(sexp_uint_t i) { return res; } -sexp make_opcode_procedure(opcode op, sexp_uint_t i, env e) { - bytecode bc = (bytecode) SEXP_ALLOC(sizeof(struct bytecode)+INIT_BCODE_SIZE); - sexp params = make_param_list(i); +sexp make_opcode_procedure(sexp op, sexp_uint_t i, sexp e) { + sexp bc, params, res; sexp_uint_t pos=0, d=0; + if (i == sexp_opcode_num_args(op) && sexp_opcode_proc(op)) + return sexp_opcode_proc(op); + bc = (sexp) SEXP_ALLOC(sexp_sizeof(bytecode)+INIT_BCODE_SIZE); + params = make_param_list(i); e = extend_env_closure(e, params, -4); bc->tag = SEXP_BYTECODE; - bc->len = INIT_BCODE_SIZE; - analyze_opcode(op, sexp_cons((sexp) op, params), &bc, &pos, e, params, + sexp_bytecode_length(bc) = INIT_BCODE_SIZE; + analyze_opcode(op, sexp_cons(op, params), &bc, &pos, e, params, SEXP_NULL, SEXP_NULL, &d, 0); emit(&bc, &pos, OP_RET); shrink_bcode(&bc, pos); /* disasm(bc); */ - return sexp_make_procedure(0, (int) sexp_make_integer(i), - (sexp) bc, SEXP_UNDEF); + res = sexp_make_procedure(0, (int) sexp_make_integer(i), bc, SEXP_UNDEF); + if (i == sexp_opcode_num_args(op)) + sexp_opcode_proc(op) = res; + return res; } -bytecode compile(sexp params, sexp obj, env e, sexp fv, sexp sv, int done_p) { +sexp compile(sexp params, sexp obj, sexp e, sexp fv, sexp sv, int done_p) { sexp_uint_t i = 0, j, d = 0, core, define_ok=1; - bytecode bc = (bytecode) SEXP_ALLOC(sizeof(struct bytecode)+INIT_BCODE_SIZE); + sexp bc = (sexp) SEXP_ALLOC(sexp_sizeof(bytecode)+INIT_BCODE_SIZE); sexp sv2 = set_vars(e, params, obj, SEXP_NULL), internals=SEXP_NULL, ls; bc->tag = SEXP_BYTECODE; - bc->len = INIT_BCODE_SIZE; + sexp_bytecode_length(bc) = INIT_BCODE_SIZE; sexp_debug("set-vars: ", sv2); /* box mutable vars */ for (ls=params; SEXP_PAIRP(ls); ls=SEXP_CDR(ls)) { @@ -581,7 +588,7 @@ bytecode compile(sexp params, sexp obj, env e, sexp fv, sexp sv, int done_p) { } sv = sexp_append(sv2, sv); /* determine internal defines */ - if (e->parent) { + if (sexp_env_parent(e)) { for (ls=SEXP_NULL; SEXP_PAIRP(obj); obj=SEXP_CDR(obj)) { core = (SEXP_PAIRP(SEXP_CAR(obj)) && SEXP_SYMBOLP(SEXP_CAAR(obj)) ? core_code(e, SEXP_CAAR(obj)) : 0); @@ -661,8 +668,8 @@ sexp_uint_t sexp_restore_stack(sexp saved, sexp *current) { #define sexp_raise(exn) {stack[top++]=(exn); goto call_error_handler;} -sexp vm(bytecode bc, env e, sexp* stack, sexp_sint_t top) { - unsigned char *ip=bc->data; +sexp vm(sexp bc, sexp e, sexp* stack, sexp_sint_t top) { + unsigned char *ip=sexp_bytecode_data(bc); sexp cp=SEXP_UNDEF, tmp1, tmp2; sexp_sint_t i, j, k; @@ -868,7 +875,7 @@ sexp vm(bytecode bc, env e, sexp* stack, sexp_sint_t top) { make_call: if (SEXP_OPCODEP(tmp1)) /* hack, compile an opcode application on the fly */ - tmp1 = make_opcode_procedure((opcode) tmp1, i, e); + tmp1 = make_opcode_procedure(tmp1, i, e); /* print_stack(stack, top); */ if (! SEXP_PROCEDUREP(tmp1)) { fprintf(stderr, "error: non-procedure app: "); @@ -914,7 +921,7 @@ sexp vm(bytecode bc, env e, sexp* stack, sexp_sint_t top) { bc = sexp_procedure_code(tmp1); /* print_bytecode(bc); */ /* disasm(bc); */ - ip = bc->data; + ip = sexp_bytecode_data(bc); cp = sexp_procedure_vars(tmp1); /* fprintf(stderr, "... calling procedure at %p\ncp: ", ip); */ /* /\* sexp_write(cp, stderr); *\/ */ @@ -948,7 +955,7 @@ sexp vm(bytecode bc, env e, sexp* stack, sexp_sint_t top) { sexp_vector(1, sexp_save_stack(stack, top+3))); top+=3; bc = sexp_procedure_code(tmp1); - ip = bc->data; + ip = sexp_bytecode_data(bc); cp = sexp_procedure_vars(tmp1); break; case OP_RESUMECC: @@ -979,7 +986,7 @@ sexp vm(bytecode bc, env e, sexp* stack, sexp_sint_t top) { stack[top+2] = cp; top+=3; bc = sexp_procedure_code(tmp1); - ip = bc->data; + ip = sexp_bytecode_data(bc); cp = sexp_procedure_vars(tmp1); break; case OP_FCALL0: @@ -1096,7 +1103,7 @@ sexp sexp_load (sexp source) { closep = 1; } while ((obj=sexp_read(source)) != (sexp) SEXP_EOF) - eval_in_stack(obj, (env) interaction_environment, stack, 0); + eval_in_stack(obj, interaction_environment, stack, 0); if (closep) sexp_close_port(source); SEXP_FREE(stack); return SEXP_UNDEF; @@ -1104,67 +1111,67 @@ sexp sexp_load (sexp source) { /*********************** standard environment *************************/ -static const struct core_form core_forms[] = { - {SEXP_CORE, CORE_DEFINE, "define"}, - {SEXP_CORE, CORE_SET, "set!"}, - {SEXP_CORE, CORE_LAMBDA, "lambda"}, - {SEXP_CORE, CORE_IF, "if"}, - {SEXP_CORE, CORE_BEGIN, "begin"}, - {SEXP_CORE, CORE_QUOTE, "quote"}, - {SEXP_CORE, CORE_DEFINE_SYNTAX, "define-syntax"}, - {SEXP_CORE, CORE_LET_SYNTAX, "let-syntax"}, - {SEXP_CORE, CORE_LETREC_SYNTAX, "letrec-syntax"}, +static struct sexp_struct core_forms[] = { + {.tag=SEXP_CORE, .value={.core={CORE_DEFINE, "define"}}}, + {.tag=SEXP_CORE, .value={.core={CORE_SET, "set!"}}}, + {.tag=SEXP_CORE, .value={.core={CORE_LAMBDA, "lambda"}}}, + {.tag=SEXP_CORE, .value={.core={CORE_IF, "if"}}}, + {.tag=SEXP_CORE, .value={.core={CORE_BEGIN, "begin"}}}, + {.tag=SEXP_CORE, .value={.core={CORE_QUOTE, "quote"}}}, + {.tag=SEXP_CORE, .value={.core={CORE_DEFINE_SYNTAX, "define-syntax"}}}, + {.tag=SEXP_CORE, .value={.core={CORE_LET_SYNTAX, "let-syntax"}}}, + {.tag=SEXP_CORE, .value={.core={CORE_LETREC_SYNTAX, "letrec-syntax"}}}, }; -static const struct opcode opcodes[] = { -#define _OP(c,o,n,m,t,u,i,s) {SEXP_OPCODE, c, o, n, m, t, u, i, s, NULL, NULL} -#define _FN(o,n,t,u,s,f) {SEXP_OPCODE, OPC_FOREIGN, o, n, 0, t,u, 0, s, (sexp)f, NULL} +static struct sexp_struct opcodes[] = { +#define _OP(c,o,n,m,t,u,i,s,d,p) {.tag=SEXP_OPCODE, .value={.opcode={c, o, n, m, t, u, i, s, d, p}}} +#define _FN(o,n,t,u,s,f) _OP(OPC_FOREIGN, o, n, 0, t, u, 0, s, (sexp)f, NULL) #define _FN0(s, f) _FN(OP_FCALL0, 0, 0, 0, s, f) #define _FN1(t, s, f) _FN(OP_FCALL1, 1, t, 0, s, f) #define _FN2(t, u, s, f) _FN(OP_FCALL2, 2, t, u, s, f) -#define _PARAM(n,a,t) {SEXP_OPCODE, OPC_PARAMETER, OP_PARAMETER, 0, 1, t, 0, 0, n, a, NULL} -_OP(OPC_ACCESSOR, OP_CAR, 1, 0, SEXP_PAIR, 0, 0, "car"), -_OP(OPC_ACCESSOR, OP_SET_CAR, 2, 0, SEXP_PAIR, 0, 0, "set-car!"), -_OP(OPC_ACCESSOR, OP_CDR, 1, 0, SEXP_PAIR, 0, 0, "cdr"), -_OP(OPC_ACCESSOR, OP_SET_CDR, 2, 0, SEXP_PAIR, 0, 0, "set-cdr!"), -_OP(OPC_ACCESSOR, OP_VECTOR_REF,2,0, SEXP_VECTOR, SEXP_FIXNUM, 0,"vector-ref"), -_OP(OPC_ACCESSOR, OP_VECTOR_SET,3,0, SEXP_VECTOR, SEXP_FIXNUM, 0,"vector-set!"), -_OP(OPC_ACCESSOR, OP_STRING_REF,2,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-ref"), -_OP(OPC_ACCESSOR, OP_STRING_SET,3,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-set!"), -_OP(OPC_ARITHMETIC, OP_ADD, 0, 1, SEXP_FIXNUM, 0, 0, "+"), -_OP(OPC_ARITHMETIC, OP_MUL, 0, 1, SEXP_FIXNUM, 0, 0, "*"), -_OP(OPC_ARITHMETIC_INV, OP_SUB, 0, 1, SEXP_FIXNUM, 0, OP_NEG, "-"), -_OP(OPC_ARITHMETIC_INV, OP_DIV, 0, 1, SEXP_FIXNUM, 0, OP_INV, "/"), -_OP(OPC_ARITHMETIC, OP_MOD, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, 0, "%"), -_OP(OPC_ARITHMETIC_CMP, OP_LT, 0, 1, SEXP_FIXNUM, 0, 0, "<"), -_OP(OPC_ARITHMETIC_CMP, OP_LE, 0, 1, SEXP_FIXNUM, 0, 0, "<="), -_OP(OPC_ARITHMETIC_CMP, OP_GT, 0, 1, SEXP_FIXNUM, 0, 0, ">"), -_OP(OPC_ARITHMETIC_CMP, OP_GE, 0, 1, SEXP_FIXNUM, 0, 0, ">="), -_OP(OPC_ARITHMETIC_CMP, OP_EQN, 0, 1, SEXP_FIXNUM, 0, 0, "="), -_OP(OPC_PREDICATE, OP_EQ, 2, 0, 0, 0, 0, "eq?"), -_OP(OPC_CONSTRUCTOR, OP_CONS, 2, 0, 0, 0, 0, "cons"), -_OP(OPC_CONSTRUCTOR, OP_MAKE_VECTOR, 2, 0, SEXP_FIXNUM, 0, 0, "make-vector"), -_OP(OPC_CONSTRUCTOR, OP_MAKE_PROCEDURE, 4, 0, 0, 0, 0, "make-procedure"), -_OP(OPC_TYPE_PREDICATE, OP_PAIRP, 1, 0, 0, 0, 0, "pair?"), -_OP(OPC_TYPE_PREDICATE, OP_NULLP, 1, 0, 0, 0, 0, "null?"), -_OP(OPC_TYPE_PREDICATE, OP_STRINGP, 1, 0, 0, 0, 0, "string?"), -_OP(OPC_TYPE_PREDICATE, OP_SYMBOLP, 1, 0, 0, 0, 0, "symbol?"), -_OP(OPC_TYPE_PREDICATE, OP_CHARP, 1, 0, 0, 0, 0, "char?"), -_OP(OPC_TYPE_PREDICATE, OP_VECTORP, 1, 0, 0, 0, 0, "vector?"), -_OP(OPC_TYPE_PREDICATE, OP_PROCEDUREP, 1, 0, 0, 0, 0, "procedure?"), -_OP(OPC_TYPE_PREDICATE, OP_IPORTP, 1, 0, 0, 0, 0, "input-port?"), -_OP(OPC_TYPE_PREDICATE, OP_OPORTP, 1, 0, 0, 0, 0, "output-port?"), -_OP(OPC_TYPE_PREDICATE, OP_EOFP, 1, 0, 0, 0, 0, "eof-object?"), -_OP(OPC_GENERIC, OP_APPLY1, 2, 0, SEXP_PROCEDURE, SEXP_PAIR, 0, "apply1"), -_OP(OPC_GENERIC, OP_CALLCC, 1, SEXP_PROCEDURE, 0, 0, 0, "call-with-current-continuation"), -_OP(OPC_GENERIC, OP_ERROR, 1, SEXP_STRING, 0, 0, 0, "error"), -{SEXP_OPCODE, OPC_IO, OP_WRITE, 1, 1, 0, SEXP_OPORT, 0, "write", (sexp)&cur_output_port, NULL}, -{SEXP_OPCODE, OPC_IO, OP_DISPLAY, 1, 1, 0, SEXP_OPORT, 0, "display", (sexp)&cur_output_port, NULL}, -{SEXP_OPCODE, OPC_IO, OP_WRITE_CHAR, 1, 1, 0, SEXP_OPORT, 0, "write-char", (sexp)&cur_output_port, NULL}, -{SEXP_OPCODE, OPC_IO, OP_NEWLINE, 0, 1, 0, SEXP_OPORT, 0, "newline", (sexp)&cur_output_port, NULL}, -{SEXP_OPCODE, OPC_IO, OP_FLUSH_OUTPUT, 0, 1, 0, SEXP_OPORT, 0, "flush-output", (sexp)&cur_output_port, NULL}, -{SEXP_OPCODE, OPC_IO, OP_READ, 0, 1, 0, SEXP_IPORT, 0, "read", (sexp)&cur_input_port, NULL}, -{SEXP_OPCODE, OPC_IO, OP_READ_CHAR, 0, 1, 0, SEXP_IPORT, 0, "read-char", (sexp)&cur_input_port, NULL}, +#define _PARAM(n,a,t) _OP(OPC_PARAMETER, OP_PARAMETER, 0, 1, t, 0, 0, n, a, NULL) +_OP(OPC_ACCESSOR, OP_CAR, 1, 0, SEXP_PAIR, 0, 0, "car", NULL, NULL), +_OP(OPC_ACCESSOR, OP_SET_CAR, 2, 0, SEXP_PAIR, 0, 0, "set-car!", NULL, NULL), +_OP(OPC_ACCESSOR, OP_CDR, 1, 0, SEXP_PAIR, 0, 0, "cdr", NULL, NULL), +_OP(OPC_ACCESSOR, OP_SET_CDR, 2, 0, SEXP_PAIR, 0, 0, "set-cdr!", NULL, NULL), +_OP(OPC_ACCESSOR, OP_VECTOR_REF,2,0, SEXP_VECTOR, SEXP_FIXNUM, 0,"vector-ref", NULL, NULL), +_OP(OPC_ACCESSOR, OP_VECTOR_SET,3,0, SEXP_VECTOR, SEXP_FIXNUM, 0,"vector-set!", NULL, NULL), +_OP(OPC_ACCESSOR, OP_STRING_REF,2,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-ref", NULL, NULL), +_OP(OPC_ACCESSOR, OP_STRING_SET,3,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-set!", NULL, NULL), +_OP(OPC_ARITHMETIC, OP_ADD, 0, 1, SEXP_FIXNUM, 0, 0, "+", NULL, NULL), +_OP(OPC_ARITHMETIC, OP_MUL, 0, 1, SEXP_FIXNUM, 0, 0, "*", NULL, NULL), +_OP(OPC_ARITHMETIC_INV, OP_SUB, 0, 1, SEXP_FIXNUM, 0, OP_NEG, "-", NULL, NULL), +_OP(OPC_ARITHMETIC_INV, OP_DIV, 0, 1, SEXP_FIXNUM, 0, OP_INV, "/", NULL, NULL), +_OP(OPC_ARITHMETIC, OP_MOD, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, 0, "%", NULL, NULL), +_OP(OPC_ARITHMETIC_CMP, OP_LT, 0, 1, SEXP_FIXNUM, 0, 0, "<", NULL, NULL), +_OP(OPC_ARITHMETIC_CMP, OP_LE, 0, 1, SEXP_FIXNUM, 0, 0, "<=", NULL, NULL), +_OP(OPC_ARITHMETIC_CMP, OP_GT, 0, 1, SEXP_FIXNUM, 0, 0, ">", NULL, NULL), +_OP(OPC_ARITHMETIC_CMP, OP_GE, 0, 1, SEXP_FIXNUM, 0, 0, ">=", NULL, NULL), +_OP(OPC_ARITHMETIC_CMP, OP_EQN, 0, 1, SEXP_FIXNUM, 0, 0, "=", NULL, NULL), +_OP(OPC_PREDICATE, OP_EQ, 2, 0, 0, 0, 0, "eq?", NULL, NULL), +_OP(OPC_CONSTRUCTOR, OP_CONS, 2, 0, 0, 0, 0, "cons", NULL, NULL), +_OP(OPC_CONSTRUCTOR, OP_MAKE_VECTOR, 2, 0, SEXP_FIXNUM, 0, 0, "make-vector", NULL, NULL), +_OP(OPC_CONSTRUCTOR, OP_MAKE_PROCEDURE, 4, 0, 0, 0, 0, "make-procedure", NULL, NULL), +_OP(OPC_TYPE_PREDICATE, OP_PAIRP, 1, 0, 0, 0, 0, "pair?", NULL, NULL), +_OP(OPC_TYPE_PREDICATE, OP_NULLP, 1, 0, 0, 0, 0, "null?", NULL, NULL), +_OP(OPC_TYPE_PREDICATE, OP_STRINGP, 1, 0, 0, 0, 0, "string?", NULL, NULL), +_OP(OPC_TYPE_PREDICATE, OP_SYMBOLP, 1, 0, 0, 0, 0, "symbol?", NULL, NULL), +_OP(OPC_TYPE_PREDICATE, OP_CHARP, 1, 0, 0, 0, 0, "char?", NULL, NULL), +_OP(OPC_TYPE_PREDICATE, OP_VECTORP, 1, 0, 0, 0, 0, "vector?", NULL, NULL), +_OP(OPC_TYPE_PREDICATE, OP_PROCEDUREP, 1, 0, 0, 0, 0, "procedure?", NULL, NULL), +_OP(OPC_TYPE_PREDICATE, OP_IPORTP, 1, 0, 0, 0, 0, "input-port?", NULL, NULL), +_OP(OPC_TYPE_PREDICATE, OP_OPORTP, 1, 0, 0, 0, 0, "output-port?", NULL, NULL), +_OP(OPC_TYPE_PREDICATE, OP_EOFP, 1, 0, 0, 0, 0, "eof-object?", NULL, NULL), +_OP(OPC_GENERIC, OP_APPLY1, 2, 0, SEXP_PROCEDURE, SEXP_PAIR, 0, "apply1", NULL, NULL), +_OP(OPC_GENERIC, OP_CALLCC, 1, SEXP_PROCEDURE, 0, 0, 0, "call-with-current-continuation", NULL, NULL), +_OP(OPC_GENERIC, OP_ERROR, 1, SEXP_STRING, 0, 0, 0, "error", NULL, NULL), +_OP(OPC_IO, OP_WRITE, 1, 1, 0, SEXP_OPORT, 0, "write", (sexp)&cur_output_port, NULL), +_OP(OPC_IO, OP_DISPLAY, 1, 1, 0, SEXP_OPORT, 0, "display", (sexp)&cur_output_port, NULL), +_OP(OPC_IO, OP_WRITE_CHAR, 1, 1, 0, SEXP_OPORT, 0, "write-char", (sexp)&cur_output_port, NULL), +_OP(OPC_IO, OP_NEWLINE, 0, 1, 0, SEXP_OPORT, 0, "newline", (sexp)&cur_output_port, NULL), +_OP(OPC_IO, OP_FLUSH_OUTPUT, 0, 1, 0, SEXP_OPORT, 0, "flush-output", (sexp)&cur_output_port, NULL), +_OP(OPC_IO, OP_READ, 0, 1, 0, SEXP_IPORT, 0, "read", (sexp)&cur_input_port, NULL), +_OP(OPC_IO, OP_READ_CHAR, 0, 1, 0, SEXP_IPORT, 0, "read-char", (sexp)&cur_input_port, NULL), _FN1(SEXP_PAIR, "length", sexp_length), _FN1(SEXP_PAIR, "reverse", sexp_reverse), _FN1(SEXP_PAIR, "list->vector", sexp_list_to_vector), @@ -1188,28 +1195,28 @@ _PARAM("interaction-environment", (sexp)&interaction_environment, SEXP_ENV), #undef _PARAM }; -env make_standard_env() { +sexp make_standard_env() { sexp_uint_t i; - env e = (env) SEXP_ALLOC(sizeof(struct env)); + sexp e = (sexp) SEXP_ALLOC(sexp_sizeof(env)); e->tag = SEXP_ENV; - e->parent = NULL; - e->bindings = SEXP_NULL; - for (i=0; i<(sizeof(core_forms)/sizeof(struct core_form)); i++) - env_define(e, sexp_intern(core_forms[i].name), (sexp)(&core_forms[i])); - for (i=0; i<(sizeof(opcodes)/sizeof(struct opcode)); i++) - env_define(e, sexp_intern(opcodes[i].name), (sexp)(&opcodes[i])); + sexp_env_parent(e) = NULL; + sexp_env_bindings(e) = SEXP_NULL; + for (i=0; i<(sizeof(core_forms)/sizeof(core_forms[0])); i++) + env_define(e, sexp_intern(sexp_core_name(&core_forms[i])), &core_forms[i]); + for (i=0; i<(sizeof(opcodes)/sizeof(opcodes[0])); i++) + env_define(e, sexp_intern(sexp_opcode_name(&opcodes[i])), &opcodes[i]); return e; } /************************** eval interface ****************************/ -sexp eval_in_stack(sexp obj, env e, sexp* stack, sexp_sint_t top) { - bytecode bc; +sexp eval_in_stack(sexp obj, sexp e, sexp* stack, sexp_sint_t top) { + sexp bc; bc = compile(SEXP_NULL, sexp_cons(obj, SEXP_NULL), e, SEXP_NULL, SEXP_NULL, 1); return vm(bc, e, stack, top); } -sexp eval(sexp obj, env e) { +sexp eval(sexp obj, sexp e) { sexp* stack = (sexp*) SEXP_ALLOC(sizeof(sexp) * INIT_STACK_SIZE); sexp res = eval_in_stack(obj, e, stack, 0); SEXP_FREE(stack); @@ -1217,7 +1224,7 @@ sexp eval(sexp obj, env e) { } void scheme_init() { - bytecode bc; + sexp bc; sexp_uint_t i=0; if (! scheme_initialized_p) { scheme_initialized_p = 1; @@ -1225,15 +1232,15 @@ void scheme_init() { cur_input_port = sexp_make_input_port(stdin); cur_output_port = sexp_make_output_port(stdout); cur_error_port = sexp_make_output_port(stderr); - bc = (bytecode) SEXP_ALLOC(sizeof(struct bytecode)+16); + bc = (sexp) SEXP_ALLOC(sexp_sizeof(bytecode)+16); bc->tag = SEXP_BYTECODE; - bc->len = 16; + sexp_bytecode_length(bc) = 16; emit(&bc, &i, OP_RESUMECC); continuation_resumer = (sexp) bc; } } -void repl (env e, sexp *stack) { +void repl (sexp e, sexp *stack) { sexp obj, res; while (1) { sexp_write_string("> ", cur_output_port); @@ -1250,23 +1257,20 @@ void repl (env e, sexp *stack) { } int main (int argc, char **argv) { - sexp obj, res, in, out, *stack, err_handler, err_handler_sym; - env e; - bytecode bc; + sexp bc, e, obj, res, in, out, *stack, err_handler, err_handler_sym; sexp_uint_t i, quit=0, init_loaded=0; - FILE *stream; scheme_init(); stack = (sexp*) SEXP_ALLOC(sizeof(sexp) * INIT_STACK_SIZE); e = make_standard_env(); - interaction_environment = (sexp) e; - bc = (bytecode) SEXP_ALLOC(sizeof(struct bytecode)+16); + interaction_environment = e; + bc = (sexp) SEXP_ALLOC(sexp_sizeof(bytecode)+16); bc->tag = SEXP_BYTECODE; - bc->len = 16; + sexp_bytecode_length(bc) = 16; i = 0; emit_push(&bc, &i, (sexp_uint_t) SEXP_UNDEF); emit(&bc, &i, OP_DONE); - err_handler = sexp_make_procedure(0, 0, (sexp)bc, sexp_make_vector(0, SEXP_UNDEF)); + err_handler = sexp_make_procedure(0, 0, bc, sexp_make_vector(0, SEXP_UNDEF)); err_handler_sym = sexp_intern("*error-handler*"); env_define(e, err_handler_sym, err_handler); exception_handler_cell = env_cell(e, err_handler_sym); diff --git a/eval.h b/eval.h index 60152ca3..8ad788b5 100644 --- a/eval.h +++ b/eval.h @@ -16,6 +16,7 @@ #define sexp_debug(msg, obj) (sexp_write_string(msg,cur_error_port), sexp_write(obj, cur_error_port), sexp_write_char('\n',cur_error_port)) +/* procedure types */ typedef sexp (*sexp_proc0) (); typedef sexp (*sexp_proc1) (sexp); typedef sexp (*sexp_proc2) (sexp, sexp); @@ -25,52 +26,6 @@ typedef sexp (*sexp_proc5) (sexp, sexp, sexp, sexp, sexp); typedef sexp (*sexp_proc6) (sexp, sexp, sexp, sexp, sexp, sexp); typedef sexp (*sexp_proc7) (sexp, sexp, sexp, sexp, sexp, sexp, sexp); -typedef struct bytecode { - char tag; - unsigned int len; - unsigned char data[]; -} *bytecode; - -typedef struct procedure { - char tag; - char flags; - unsigned short num_args; - bytecode bc; - sexp vars; -} *procedure; - -typedef struct env { - char tag; - struct env *parent; - sexp bindings; -} *env; - -typedef struct macro { - char tag; - procedure proc; - env e; -} *macro; - -typedef struct opcode { - char tag; - char op_class; - char op_name; - char num_args; - char var_args_p; - char arg1_type; - char arg2_type; - char op_inverse; - char* name; - sexp data; - sexp proc; -} *opcode; - -typedef struct core_form { - char tag; - char code; - char* name; -} *core_form; - enum core_form_names { CORE_DEFINE = 1, CORE_SET, @@ -172,22 +127,22 @@ enum opcode_names { /**************************** prototypes ******************************/ -bytecode compile(sexp params, sexp obj, env e, sexp fv, sexp sv, int done_p); +sexp compile(sexp params, sexp obj, sexp e, sexp fv, sexp sv, int done_p); -void analyze_app (sexp obj, bytecode *bc, sexp_uint_t *i, - env e, sexp params, sexp fv, sexp sv, +void analyze_app (sexp obj, sexp *bc, sexp_uint_t *i, + sexp e, sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp); void analyze_lambda (sexp name, sexp formals, sexp body, - bytecode *bc, sexp_uint_t *i, env e, + sexp *bc, sexp_uint_t *i, sexp e, sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp); -void analyze_var_ref (sexp name, bytecode *bc, sexp_uint_t *i, env e, +void analyze_var_ref (sexp name, sexp *bc, sexp_uint_t *i, sexp e, sexp params, sexp fv, sexp sv, sexp_uint_t *d); -void analyze_opcode (opcode op, sexp obj, bytecode *bc, sexp_uint_t *i, env e, +void analyze_opcode (sexp op, sexp obj, sexp *bc, sexp_uint_t *i, sexp e, sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp); -sexp vm(bytecode bc, env e, sexp* stack, sexp_sint_t top); +sexp vm(sexp bc, sexp e, sexp* stack, sexp_sint_t top); -sexp eval_in_stack(sexp obj, env e, sexp* stack, sexp_sint_t top); -sexp eval(sexp obj, env e); +sexp eval_in_stack(sexp expr, sexp e, sexp* stack, sexp_sint_t top); +sexp eval(sexp expr, sexp e); #endif /* ! SEXP_EVAL_H */ diff --git a/sexp.c b/sexp.c index 46597787..837a1df6 100644 --- a/sexp.c +++ b/sexp.c @@ -79,10 +79,12 @@ void sexp_free (sexp obj) { /*************************** list utilities ***************************/ sexp sexp_cons(sexp head, sexp tail) { - sexp pair = SEXP_NEW(); + sexp pair = SEXP_ALLOC(sexp_sizeof(pair)); pair->tag = SEXP_PAIR; - pair->data1 = (void*) head; - pair->data2 = (void*) tail; +/* pair->data1 = (void*) head; */ +/* pair->data2 = (void*) tail; */ + SEXP_CAR(pair) = head; + SEXP_CDR(pair) = tail; return pair; } @@ -170,20 +172,22 @@ sexp sexp_length(sexp ls) { /********************* strings, symbols, vectors **********************/ sexp sexp_make_flonum(double f) { - sexp x = SEXP_NEW(); + sexp x = SEXP_ALLOC(sexp_sizeof(flonum)); x->tag = SEXP_FLONUM; sexp_flonum_value(x) = f; return x; } sexp sexp_make_string(char *str) { - sexp s = SEXP_NEW(); - unsigned long len = strlen(str); + sexp s = SEXP_ALLOC(sexp_sizeof(string)); + sexp_uint_t len = strlen(str); char *mystr = SEXP_ALLOC(len+1); memcpy(mystr, str, len+1); s->tag = SEXP_STRING; - s->data1 = (void*) len; - s->data2 = (void*) mystr; +/* s->data1 = (void*) len; */ +/* s->data2 = (void*) mystr; */ + sexp_string_length(s) = len; + sexp_string_data(s) = mystr; return s; } @@ -240,14 +244,16 @@ sexp sexp_intern(char *str) { symbol_table = newtable; } - sym = SEXP_NEW(); + sym = SEXP_ALLOC(sexp_sizeof(symbol)); len = strlen(str); mystr = SEXP_ALLOC(len+1); memcpy(mystr, str, len+1); mystr[len]=0; sym->tag = SEXP_SYMBOL; - sym->data1 = (void*) len; - sym->data2 = (void*) mystr; +/* sym->data1 = (void*) len; */ +/* sym->data2 = (void*) mystr; */ + sexp_symbol_length(sym) = len; + sexp_symbol_data(sym) = mystr; symbol_table[cell] = sym; return symbol_table[cell]; } @@ -256,14 +262,16 @@ 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_NEW(); - x = (void*) SEXP_ALLOC(clen*sizeof(sexp)); + v = SEXP_ALLOC(sexp_sizeof(vector)); + x = (sexp*) SEXP_ALLOC(clen*sizeof(sexp)); for (i=0; itag = SEXP_VECTOR; - v->data1 = (void*) clen; - v->data2 = (void*) x; +/* v->data1 = (void*) clen; */ +/* v->data2 = (void*) x; */ + sexp_vector_length(v) = clen; + sexp_vector_data(v) = x; return v; } @@ -325,16 +333,18 @@ int sstream_close(void *vec) { } sexp sexp_make_input_port(FILE* in) { - sexp p = SEXP_NEW(); + sexp p = SEXP_ALLOC(sexp_sizeof(port)); p->tag = SEXP_IPORT; - p->data1 = in; + /* p->data1 = in; */ + sexp_port_stream(p) = in; return p; } sexp sexp_make_output_port(FILE* out) { - sexp p = SEXP_NEW(); + sexp p = SEXP_ALLOC(sexp_sizeof(port)); p->tag = SEXP_OPORT; - p->data1 = out; + /* p->data1 = out; */ + sexp_port_stream(p) = out; return p; } @@ -782,10 +792,12 @@ void sexp_init() { the_quasiquote_symbol = sexp_intern("quasiquote"); the_unquote_symbol = sexp_intern("unquote"); the_unquote_splicing_symbol = sexp_intern("unquote-splicing"); - the_empty_vector = SEXP_NEW(); + the_empty_vector = SEXP_ALLOC(sexp_sizeof(vector)); the_empty_vector->tag = SEXP_VECTOR; - the_empty_vector->data1 = 0; - the_empty_vector->data2 = 0; +/* the_empty_vector->data1 = 0; */ +/* the_empty_vector->data2 = 0; */ + sexp_vector_length(the_empty_vector) = 0; + sexp_vector_data(the_empty_vector) = NULL; } } diff --git a/sexp.h b/sexp.h index d8338949..04711802 100644 --- a/sexp.h +++ b/sexp.h @@ -16,7 +16,7 @@ #if HAVE_ERR_H #include #else -/* requires that msg be a string literal */ +/* requires msg be a string literal, and at least one argument */ #define errx(code, msg, ...) (fprintf(stderr,msg"\n",__VA_ARGS__), exit(code)) #endif @@ -63,6 +63,7 @@ #define SEXP_LSYMBOL_TAG 3 #define SEXP_ISYMBOL_TAG 7 #define SEXP_CHAR_TAG 6 +#define SEXP_EXTENDED_TAG 14 enum sexp_types { SEXP_OBJECT, @@ -87,24 +88,79 @@ enum sexp_types { SEXP_OPCODE, }; -typedef struct sexp_struct { - char tag; - void *data1; - void *data2; -} *sexp; - typedef unsigned long sexp_uint_t; typedef long sexp_sint_t; +typedef char sexp_tag_t; +typedef struct sexp_struct *sexp; -#define MAKE_IMMEDIATE(n) ((sexp) ((n<<4) + 14)) -#define SEXP_NULL MAKE_IMMEDIATE(0) -#define SEXP_FALSE MAKE_IMMEDIATE(1) -#define SEXP_TRUE MAKE_IMMEDIATE(2) -#define SEXP_EOF MAKE_IMMEDIATE(3) -#define SEXP_UNDEF MAKE_IMMEDIATE(4) -#define SEXP_ERROR MAKE_IMMEDIATE(5) -#define SEXP_CLOSE MAKE_IMMEDIATE(6) /* internal use */ -#define SEXP_RAWDOT MAKE_IMMEDIATE(7) /* internal use */ +struct sexp_struct { + sexp_tag_t tag; + union { + double flonum; + struct { + sexp car, cdr; + } pair; + struct { + sexp_uint_t length; + sexp *data; + } vector; + struct { + sexp_uint_t length; + char *data; + } string; + struct { + sexp_uint_t length; + char *data; + } symbol; + struct { + FILE *stream; + char *name; + sexp_uint_t line; + } port; + struct { + sexp kind, message, irritants, file, line; + } exception; + struct { + char flags; + sexp parent, bindings; + } env; + struct { + sexp_uint_t length; + unsigned char data[]; + } bytecode; + struct { + char flags; + unsigned short num_args; + sexp bc, vars; + } procedure; + struct { + sexp proc, env; + } macro; + struct { + unsigned char op_class, code, num_args, flags, + arg1_type, arg2_type, inverse; + char *name; + sexp data, proc; + } opcode; + struct { + char code; + char *name; + } core; + } value; +}; + +#define sexp_sizeof_field(field) (sizeof((sexp)NULL)->value.field) +#define sexp_sizeof(field) (sizeof(struct sexp_struct)-sexp_sizeof_field(exception)+sexp_sizeof_field(field)) + +#define SEXP_MAKE_IMMEDIATE(n) ((sexp) ((n<tag == SEXP_PAIR) -#define SEXP_STRINGP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_STRING) -#define SEXP_LSYMBOLP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_SYMBOL) -#define SEXP_VECTORP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_VECTOR) -#define SEXP_FLONUMP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_FLONUM) -#define SEXP_IPORTP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_IPORT) -#define SEXP_OPORTP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_OPORT) -#define SEXP_PROCEDUREP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_PROCEDURE) -#define SEXP_ENVP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_ENV) -#define SEXP_BYTECODEP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag ==SEXP_BYTECODE) -#define SEXP_COREP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_CORE) -#define SEXP_OPCODEP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_OPCODE) -#define SEXP_MACROP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_MACRO) +#define SEXP_CHECK_TAG(x,t) (SEXP_POINTERP(x) && (x)->tag == (t)) + +#define SEXP_PAIRP(x) (SEXP_CHECK_TAG(x, SEXP_PAIR)) +#define SEXP_STRINGP(x) (SEXP_CHECK_TAG(x, SEXP_STRING)) +#define SEXP_LSYMBOLP(x) (SEXP_CHECK_TAG(x, SEXP_SYMBOL)) +#define SEXP_VECTORP(x) (SEXP_CHECK_TAG(x, SEXP_VECTOR)) +#define SEXP_FLONUMP(x) (SEXP_CHECK_TAG(x, SEXP_FLONUM)) +#define SEXP_IPORTP(x) (SEXP_CHECK_TAG(x, SEXP_IPORT)) +#define SEXP_OPORTP(x) (SEXP_CHECK_TAG(x, SEXP_OPORT)) +#define SEXP_EXCEPTIONP(x) (SEXP_CHECK_TAG(x, SEXP_EXCEPTION)) +#define SEXP_PROCEDUREP(x) (SEXP_CHECK_TAG(x, SEXP_PROCEDURE)) +#define SEXP_ENVP(x) (SEXP_CHECK_TAG(x, SEXP_ENV)) +#define SEXP_BYTECODEP(x) (SEXP_CHECK_TAG(x, SEXP_BYTECODE)) +#define SEXP_COREP(x) (SEXP_CHECK_TAG(x, SEXP_CORE)) +#define SEXP_OPCODEP(x) (SEXP_CHECK_TAG(x, SEXP_OPCODE)) +#define SEXP_MACROP(x) (SEXP_CHECK_TAG(x, SEXP_MACRO)) #define SEXP_SYMBOLP(x) (SEXP_ISYMBOLP(x) || SEXP_LSYMBOLP(x)) #if USE_HUFF_SYMS -#define SEXP_DOTP(x) (((sexp_uint_t)(x))==((0x5D00<>SEXP_FIXNUM_BITS) -#define sexp_make_character(n) ((sexp) (((long) n<>SEXP_EXTENDED_BITS) +#define sexp_make_integer(n) ((sexp) (((sexp_sint_t) n<>SEXP_FIXNUM_BITS) +#define sexp_make_character(n) ((sexp) (((sexp_sint_t) n<>SEXP_EXTENDED_BITS) -#define sexp_flonum_value(f) (((double*)(((sexp_uint_t)f)+sizeof(char)))[0]) +#define sexp_flonum_value(f) ((f)->value.flonum) -#define sexp_vector_length(x) ((sexp_uint_t) x->data1) -#define sexp_vector_data(x) ((sexp*) (((sexp)x)->data2)) +#define sexp_vector_length(x) ((x)->value.vector.length) +#define sexp_vector_data(x) ((x)->value.vector.data) #define sexp_vector_ref(x, i) (sexp_vector_data(x)[sexp_unbox_integer(i)]) #define sexp_vector_set(x, i, v) (sexp_vector_data(x)[sexp_unbox_integer(i)] = (v)) -#define sexp_procedure_num_args(x) (((procedure)x)->num_args) -#define sexp_procedure_variadic_p(x) (sexp_unbox_integer(((procedure)x)->flags) & 1) -#define sexp_procedure_code(x) ((bytecode) ((procedure)x)->bc) -#define sexp_procedure_vars(x) ((sexp) ((procedure)x)->vars) +#define sexp_procedure_num_args(x) ((x)->value.procedure.num_args) +#define sexp_procedure_flags(x) ((x)->value.procedure.flags) +#define sexp_procedure_variadic_p(x) (sexp_unbox_integer(sexp_procedure_flags(x)) & 1) +#define sexp_procedure_code(x) ((x)->value.procedure.bc) +#define sexp_procedure_vars(x) ((x)->value.procedure.vars) -#define sexp_string_length(x) ((sexp_uint_t) x->data1) -#define sexp_string_data(x) ((char*) x->data2) +#define sexp_string_length(x) ((x)->value.string.length) +#define sexp_string_data(x) ((x)->value.string.data) #define sexp_string_ref(x, i) (sexp_make_character(sexp_string_data(x)[sexp_unbox_integer(i)])) #define sexp_string_set(x, i, v) (sexp_string_data(x)[sexp_unbox_integer(i)] = sexp_unbox_character(v)) -#define sexp_port_stream(p) ((FILE*) ((sexp)p)->data1) +#define sexp_symbol_length(x) ((x)->value.symbol.length) +#define sexp_symbol_data(x) ((x)->value.symbol.data) + +#define sexp_port_stream(p) ((p)->value.port.stream) +#define sexp_port_name(p) ((p)->value.port.name) +#define sexp_port_line(p) ((p)->value.port.line) + +#define sexp_exception_kind(p) ((p)->value.exception.kind) +#define sexp_exception_message(p) ((p)->value.exception.message) +#define sexp_exception_irritants(p) ((p)->value.exception.irritants) +#define sexp_exception_file(p) ((p)->value.exception.file) +#define sexp_exception_line(p) ((p)->value.exception.line) + +#define sexp_bytecode_length(x) ((x)->value.bytecode.length) +#define sexp_bytecode_data(x) ((x)->value.bytecode.data) + +#define sexp_env_flags(x) ((x)->value.env.flags) +#define sexp_env_parent(x) ((x)->value.env.parent) +#define sexp_env_bindings(x) ((x)->value.env.bindings) +#define sexp_env_global_p(x) (! sexp_env_parent(x)) + +#define sexp_macro_proc(x) ((x)->value.macro.proc) +#define sexp_macro_env(x) ((x)->value.macro.env) + +#define sexp_core_code(x) ((x)->value.core.code) +#define sexp_core_name(x) ((x)->value.core.name) + +#define sexp_opcode_class(x) ((x)->value.opcode.op_class) +#define sexp_opcode_code(x) ((x)->value.opcode.code) +#define sexp_opcode_num_args(x) ((x)->value.opcode.num_args) +#define sexp_opcode_flags(x) ((x)->value.opcode.flags) +#define sexp_opcode_arg1_type(x) ((x)->value.opcode.arg1_type) +#define sexp_opcode_arg2_type(x) ((x)->value.opcode.arg2_type) +#define sexp_opcode_inverse(x) ((x)->value.opcode.inverse) +#define sexp_opcode_name(x) ((x)->value.opcode.name) +#define sexp_opcode_data(x) ((x)->value.opcode.data) +#define sexp_opcode_proc(x) ((x)->value.opcode.proc) + +#define sexp_opcode_variadic_p(x) (sexp_opcode_flags(x) & 1) #if USE_STRING_STREAMS #if SEXP_BSD @@ -183,10 +281,6 @@ void sexp_write_string(sexp str, sexp port); void sexp_printf(sexp port, sexp fmt, ...); #endif -#define sexp_symbol_pointer(x) (x) -#define sexp_symbol_length(x) ((sexp_uint_t) (sexp_symbol_pointer(x)->data1)) -#define sexp_symbol_data(x) ((char*) (sexp_symbol_pointer(x)->data2)) - #define sexp_add(a, b) ((sexp)(((sexp_sint_t)a)+((sexp_sint_t)b)-SEXP_FIXNUM_TAG)) #define sexp_sub(a, b) ((sexp)(((sexp_sint_t)a)-((sexp_sint_t)b)+SEXP_FIXNUM_TAG)) #define sexp_mul(a, b) ((sexp)((((((sexp_sint_t)a)-SEXP_FIXNUM_TAG)*(((sexp_sint_t)b)>>SEXP_FIXNUM_BITS))+SEXP_FIXNUM_TAG))) @@ -198,8 +292,8 @@ void sexp_printf(sexp port, sexp fmt, ...); #define sexp_list3(a, b, c) sexp_cons(a, sexp_cons(b, sexp_cons(c, SEXP_NULL))) #define sexp_list4(a, b, c, d) sexp_cons(a, sexp_cons(b, sexp_cons(c, sexp_cons(d, SEXP_NULL)))) -#define SEXP_CAR(x) (((sexp)x)->data1) -#define SEXP_CDR(x) (((sexp)x)->data2) +#define SEXP_CAR(x) ((x)->value.pair.car) +#define SEXP_CDR(x) ((x)->value.pair.cdr) #define SEXP_CAAR(x) (SEXP_CAR(SEXP_CAR(x))) #define SEXP_CADR(x) (SEXP_CAR(SEXP_CDR(x))) From 2c37e682efdb455f39dead8b0e313741345a6179 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 15 Mar 2009 21:23:39 +0900 Subject: [PATCH 039/154] lowercasing --- Makefile | 2 +- eval.c | 291 +++++++++++++++++++++++++++---------------------------- sexp.c | 98 ++++++++----------- sexp.h | 76 +++++++-------- 4 files changed, 225 insertions(+), 242 deletions(-) diff --git a/Makefile b/Makefile index c4228672..9b7b6efd 100644 --- a/Makefile +++ b/Makefile @@ -3,7 +3,7 @@ all: chibi-scheme -CFLAGS=-g -fno-inline -Os +CFLAGS=-g -fno-inline -save-temps -Os GC_OBJ=./gc/gc.a diff --git a/eval.c b/eval.c index b89f79af..ff409d12 100644 --- a/eval.c +++ b/eval.c @@ -27,9 +27,9 @@ static sexp env_cell(sexp e, sexp key) { sexp ls; do { - for (ls=sexp_env_bindings(e); SEXP_PAIRP(ls); ls=SEXP_CDR(ls)) - if (SEXP_CAAR(ls) == key) - return SEXP_CAR(ls); + for (ls=sexp_env_bindings(e); sexp_pairp(ls); ls=sexp_cdr(ls)) + if (sexp_caar(ls) == key) + return sexp_car(ls); e = sexp_env_parent(e); } while (e); @@ -49,7 +49,7 @@ static int env_global_p (sexp e, sexp id) { static void env_define(sexp e, sexp key, sexp value) { sexp cell = env_cell(e, key); if (cell) { - SEXP_CDR(cell) = value; + sexp_cdr(cell) = value; } else { sexp_env_bindings(e) = sexp_cons(sexp_cons(key, value), sexp_env_bindings(e)); @@ -62,24 +62,24 @@ static sexp extend_env_closure (sexp e, sexp fv, int offset) { e2->tag = SEXP_ENV; sexp_env_parent(e2) = e; sexp_env_bindings(e2) = SEXP_NULL; - for (i=offset; SEXP_PAIRP(fv); fv = SEXP_CDR(fv), i--) + for (i=offset; sexp_pairp(fv); fv = sexp_cdr(fv), i--) sexp_env_bindings(e2) - = sexp_cons(sexp_cons(SEXP_CAR(fv), sexp_make_integer(i)), + = sexp_cons(sexp_cons(sexp_car(fv), sexp_make_integer(i)), sexp_env_bindings(e2)); return e2; } static int core_code (sexp e, sexp sym) { sexp cell = env_cell(e, sym); - if (! cell || ! SEXP_COREP(SEXP_CDR(cell))) return 0; - return (sexp_core_code(SEXP_CDR(cell))); + if (! cell || ! sexp_corep(sexp_cdr(cell))) return 0; + return (sexp_core_code(sexp_cdr(cell))); } static sexp sexp_reverse_flatten_dot (sexp ls) { sexp res; - for (res=SEXP_NULL; SEXP_PAIRP(ls); ls=SEXP_CDR(ls)) - res = sexp_cons(SEXP_CAR(ls), res); - return (SEXP_NULLP(ls) ? res : sexp_cons(ls, res)); + for (res=SEXP_NULL; sexp_pairp(ls); ls=sexp_cdr(ls)) + res = sexp_cons(sexp_car(ls), res); + return (sexp_nullp(ls) ? res : sexp_cons(ls, res)); } static sexp sexp_flatten_dot (sexp ls) { @@ -180,37 +180,35 @@ void analyze(sexp obj, sexp *bc, sexp_uint_t *i, sexp e, sexp o1, o2, e2, cell; loop: - if (SEXP_PAIRP(obj)) { - if (SEXP_SYMBOLP(SEXP_CAR(obj))) { - o1 = env_cell(e, SEXP_CAR(obj)); + if (sexp_pairp(obj)) { + if (sexp_symbolp(sexp_car(obj))) { + o1 = env_cell(e, sexp_car(obj)); if (! o1) { analyze_app(obj, bc, i, e, params, fv, sv, d, tailp); return; } - o1 = SEXP_CDR(o1); - if (SEXP_COREP(o1)) { + o1 = sexp_cdr(o1); + if (sexp_corep(o1)) { switch (sexp_core_code(o1)) { case CORE_LAMBDA: - analyze_lambda(SEXP_FALSE, SEXP_CADR(obj), SEXP_CDDR(obj), + analyze_lambda(SEXP_FALSE, sexp_cadr(obj), sexp_cddr(obj), bc, i, e, params, fv, sv, d, tailp); break; case CORE_DEFINE_SYNTAX: - env_define(e, SEXP_CADR(obj), - sexp_make_macro(eval(SEXP_CADDR(obj), e), e)); + env_define(e, sexp_cadr(obj), + sexp_make_macro(eval(sexp_caddr(obj), e), e)); emit_push(bc, i, SEXP_UNDEF); (*d)++; break; case CORE_DEFINE: if ((sexp_core_code(o1) == CORE_DEFINE) - && SEXP_PAIRP(SEXP_CADR(obj))) { - o2 = SEXP_CAR(SEXP_CADR(obj)); - analyze_lambda(SEXP_CAR(SEXP_CADR(obj)), - SEXP_CDR(SEXP_CADR(obj)), - SEXP_CDDR(obj), + && sexp_pairp(sexp_cadr(obj))) { + o2 = sexp_car(sexp_cadr(obj)); + analyze_lambda(sexp_caadr(obj), sexp_cdadr(obj), sexp_cddr(obj), bc, i, e, params, fv, sv, d, 0); } else { - o2 = SEXP_CADR(obj); - analyze(SEXP_CADDR(obj), bc, i, e, params, fv, sv, d, 0); + o2 = sexp_cadr(obj); + analyze(sexp_caddr(obj), bc, i, e, params, fv, sv, d, 0); } if (sexp_env_global_p(e)) { emit(bc, i, OP_GLOBAL_SET); @@ -221,89 +219,87 @@ void analyze(sexp obj, sexp *bc, sexp_uint_t *i, sexp e, if (! o1) errx(1, "define in bad position: %p", o2); emit(bc, i, OP_STACK_SET); - emit_word(bc, i, sexp_unbox_integer(SEXP_CDR(o1))); + emit_word(bc, i, sexp_unbox_integer(sexp_cdr(o1))); } (*d)++; break; case CORE_SET: - analyze(SEXP_CADDR(obj), bc, i, e, params, fv, sv, d, 0); - if (sexp_list_index(sv, SEXP_CADR(obj)) >= 0) { - analyze_var_ref(SEXP_CADR(obj), bc, i, e, params, fv, SEXP_NULL, d); + analyze(sexp_caddr(obj), bc, i, e, params, fv, sv, d, 0); + if (sexp_list_index(sv, sexp_cadr(obj)) >= 0) { + analyze_var_ref(sexp_cadr(obj), bc, i, e, params, fv, SEXP_NULL, d); emit(bc, i, OP_SET_CAR); } else { emit(bc, i, OP_GLOBAL_SET); - emit_word(bc, i, (sexp_uint_t) SEXP_CADR(obj)); + emit_word(bc, i, (sexp_uint_t) sexp_cadr(obj)); emit_push(bc, i, SEXP_UNDEF); } break; case CORE_BEGIN: - for (o2 = SEXP_CDR(obj); SEXP_PAIRP(o2); o2 = SEXP_CDR(o2)) { - if (SEXP_PAIRP(SEXP_CDR(o2))) { - analyze(SEXP_CAR(o2), bc, i, e, params, fv, sv, d, 0); + for (o2 = sexp_cdr(obj); sexp_pairp(o2); o2 = sexp_cdr(o2)) { + if (sexp_pairp(sexp_cdr(o2))) { + analyze(sexp_car(o2), bc, i, e, params, fv, sv, d, 0); emit(bc, i, OP_DROP); (*d)--; } else - analyze(SEXP_CAR(o2), bc, i, e, params, fv, sv, d, tailp); + analyze(sexp_car(o2), bc, i, e, params, fv, sv, d, tailp); } break; case CORE_IF: - analyze(SEXP_CADR(obj), bc, i, e, params, fv, sv, d, 0); + analyze(sexp_cadr(obj), bc, i, e, params, fv, sv, d, 0); emit(bc, i, OP_JUMP_UNLESS); /* jumps if test fails */ (*d)--; tmp1 = *i; emit(bc, i, 0); - analyze(SEXP_CADDR(obj), bc, i, e, params, fv, sv, d, tailp); + analyze(sexp_caddr(obj), bc, i, e, params, fv, sv, d, tailp); emit(bc, i, OP_JUMP); (*d)--; tmp2 = *i; emit(bc, i, 0); - /* ((signed char*) (*bc)->data)[tmp1] = (*i)-tmp1; /\* patch *\/ */ ((signed char*) sexp_bytecode_data(*bc))[tmp1] = (*i)-tmp1; - if (SEXP_PAIRP(SEXP_CDDDR(obj))) { - analyze(SEXP_CADDDR(obj), bc, i, e, params, fv, sv, d, tailp); + if (sexp_pairp(sexp_cdddr(obj))) { + analyze(sexp_cadddr(obj), bc, i, e, params, fv, sv, d, tailp); } else { emit_push(bc, i, SEXP_UNDEF); (*d)++; } - /* ((signed char*) (*bc)->data)[tmp2] = (*i)-tmp2; /\* patch *\/ */ ((signed char*) sexp_bytecode_data(*bc))[tmp2] = (*i)-tmp2; break; case CORE_QUOTE: - emit_push(bc, i, SEXP_CADR(obj)); + emit_push(bc, i, sexp_cadr(obj)); (*d)++; break; default: errx(1, "unknown core form: %s", sexp_core_code(o1)); } - } else if (SEXP_OPCODEP(o1)) { + } else if (sexp_opcodep(o1)) { analyze_opcode(o1, obj, bc, i, e, params, fv, sv, d, tailp); - } else if (SEXP_MACROP(o1)) { + } else if (sexp_macrop(o1)) { obj = sexp_expand_macro(o1, obj, e); goto loop; } else { /* general procedure call */ analyze_app(obj, bc, i, e, params, fv, sv, d, tailp); } - } else if (SEXP_PAIRP(SEXP_CAR(obj))) { + } else if (sexp_pairp(sexp_car(obj))) { #if USE_FAST_LET - o2 = env_cell(e, SEXP_CAAR(obj)); + o2 = env_cell(e, sexp_caar(obj)); if (o2 - && SEXP_COREP(SEXP_CDR(o2)) + && sexp_corep(sexp_cdr(o2)) && (sexp_core_code(o2) == CORE_LAMBDA) - && sexp_listp(SEXP_CADR(SEXP_CAR(obj)))) { + && sexp_listp(sexp_cadr(sexp_car(obj)))) { /* let */ - tmp1 = sexp_unbox_integer(sexp_length(SEXP_CADR(SEXP_CAR(obj)))); - e2 = extend_env_closure(e, SEXP_CADR(SEXP_CAR(obj)), (*d)+(tmp1-1)); - for (o2=sexp_reverse(SEXP_CDR(obj)); SEXP_PAIRP(o2); o2=SEXP_CDR(o2)) - analyze(SEXP_CAR(o2), bc, i, e, params, fv, sv, d, 0); - params = sexp_append(SEXP_CADR(SEXP_CAR(obj)), params); - for (o2=SEXP_CDDR(SEXP_CAR(obj)); SEXP_PAIRP(o2); o2=SEXP_CDR(o2)) { - if (SEXP_PAIRP(SEXP_CDR(o2))) { - analyze(SEXP_CAR(o2), bc, i, e2, params, fv, sv, d, 0); + tmp1 = sexp_unbox_integer(sexp_length(sexp_cadar(obj))); + e2 = extend_env_closure(e, sexp_cadar(obj), (*d)+(tmp1-1)); + for (o2=sexp_reverse(sexp_cdr(obj)); sexp_pairp(o2); o2=sexp_cdr(o2)) + analyze(sexp_car(o2), bc, i, e, params, fv, sv, d, 0); + params = sexp_append(sexp_cadar(obj), params); + for (o2=sexp_cddar(obj); sexp_pairp(o2); o2=sexp_cdr(o2)) { + if (sexp_pairp(sexp_cdr(o2))) { + analyze(sexp_car(o2), bc, i, e2, params, fv, sv, d, 0); emit(bc, i, OP_DROP); (*d)--; } else { - analyze(SEXP_CAR(o2), bc, i, e2, params, fv, sv, d, tailp); + analyze(sexp_car(o2), bc, i, e2, params, fv, sv, d, tailp); } } emit(bc, i, OP_STACK_SET); @@ -316,9 +312,9 @@ void analyze(sexp obj, sexp *bc, sexp_uint_t *i, sexp e, /* computed application */ analyze_app(obj, bc, i, e, params, fv, sv, d, tailp); } else { - errx(1, "invalid operator: %s", SEXP_CAR(obj)); + errx(1, "invalid operator: %s", sexp_car(obj)); } - } else if (SEXP_SYMBOLP(obj)) { + } else if (sexp_symbolp(obj)) { analyze_var_ref(obj, bc, i, e, params, fv, sv, d); } else { /* literal */ emit_push(bc, i, obj); @@ -341,11 +337,11 @@ void analyze_opcode (sexp op, sexp obj, sexp *bc, sexp_uint_t *i, sexp e, case OPC_CONSTRUCTOR: case OPC_ACCESSOR: case OPC_GENERIC: - tmp1 = sexp_unbox_integer(sexp_length(SEXP_CDR(obj))); + tmp1 = sexp_unbox_integer(sexp_length(sexp_cdr(obj))); if (tmp1 == 0) { errx(1, "opcode with no arguments: %s", sexp_opcode_name(op)); } else if (tmp1 == 1) { - analyze(SEXP_CADR(obj), bc, i, e, params, fv, sv, d, 0); + analyze(sexp_cadr(obj), bc, i, e, params, fv, sv, d, 0); if (sexp_opcode_class(op) == OPC_ARITHMETIC_INV) { emit(bc, i, sexp_opcode_inverse(op)); (*d)++; @@ -353,8 +349,8 @@ void analyze_opcode (sexp op, sexp obj, sexp *bc, sexp_uint_t *i, sexp e, emit(bc, i, sexp_opcode_code(op)); } } else { - for (o1=sexp_reverse(SEXP_CDR(obj)); SEXP_PAIRP(o1); o1=SEXP_CDR(o1)) - analyze(SEXP_CAR(o1), bc, i, e, params, fv, sv, d, 0); + for (o1=sexp_reverse(sexp_cdr(obj)); sexp_pairp(o1); o1=sexp_cdr(o1)) + analyze(sexp_car(o1), bc, i, e, params, fv, sv, d, 0); emit(bc, i, sexp_opcode_code(op)); (*d) -= (tmp1-1); if (sexp_opcode_class(op) == OPC_ARITHMETIC) @@ -363,15 +359,15 @@ void analyze_opcode (sexp op, sexp obj, sexp *bc, sexp_uint_t *i, sexp e, } break; case OPC_IO: - tmp1 = sexp_unbox_integer(sexp_length(SEXP_CDR(obj))); + tmp1 = sexp_unbox_integer(sexp_length(sexp_cdr(obj))); if (tmp1 == sexp_opcode_num_args(op) && sexp_opcode_variadic_p(op)) { emit(bc, i, OP_PARAMETER); emit_word(bc, i, (sexp_uint_t) sexp_opcode_data(op)); (*d)++; tmp1++; } - for (o1=sexp_reverse(SEXP_CDR(obj)); SEXP_PAIRP(o1); o1=SEXP_CDR(o1)) - analyze(SEXP_CAR(o1), bc, i, e, params, fv, sv, d, 0); + for (o1=sexp_reverse(sexp_cdr(obj)); sexp_pairp(o1); o1=sexp_cdr(o1)) + analyze(sexp_car(o1), bc, i, e, params, fv, sv, d, 0); emit(bc, i, sexp_opcode_code(op)); (*d) -= (tmp1-1); break; @@ -380,11 +376,11 @@ void analyze_opcode (sexp op, sexp obj, sexp *bc, sexp_uint_t *i, sexp e, emit_word(bc, i, (sexp_uint_t) sexp_opcode_data(op)); break; case OPC_FOREIGN: - for (o1=sexp_reverse(SEXP_CDR(obj)); SEXP_PAIRP(o1); o1=SEXP_CDR(o1)) - analyze(SEXP_CAR(o1), bc, i, e, params, fv, sv, d, 0); + for (o1=sexp_reverse(sexp_cdr(obj)); sexp_pairp(o1); o1=sexp_cdr(o1)) + analyze(sexp_car(o1), bc, i, e, params, fv, sv, d, 0); emit_push(bc, i, sexp_opcode_data(op)); emit(bc, i, sexp_opcode_code(op)); - (*d) -= (sexp_unbox_integer(sexp_length(SEXP_CDR(obj)))-1); + (*d) -= (sexp_unbox_integer(sexp_length(sexp_cdr(obj)))-1); break; default: errx(1, "unknown opcode class: %d", sexp_opcode_class(op)); @@ -402,9 +398,9 @@ void analyze_var_ref (sexp obj, sexp *bc, sexp_uint_t *i, sexp e, o1 = env_cell(e, obj); fprintf(stderr, "compiling local ref: "); sexp_write(obj, cur_error_port); - fprintf(stderr, " => %d\n", *d - sexp_unbox_integer(SEXP_CDR(o1))); + fprintf(stderr, " => %d\n", *d - sexp_unbox_integer(sexp_cdr(o1))); emit(bc, i, OP_STACK_REF); - emit_word(bc, i, *d - sexp_unbox_integer(SEXP_CDR(o1))); + emit_word(bc, i, *d - sexp_unbox_integer(sexp_cdr(o1))); } else if ((tmp = sexp_list_index(fv, obj)) >= 0) { fprintf(stderr, "compiling closure ref: %p => %d\n", obj, tmp); emit(bc, i, OP_CLOSURE_REF); @@ -416,7 +412,6 @@ void analyze_var_ref (sexp obj, sexp *bc, sexp_uint_t *i, sexp e, } (*d)++; if (sexp_list_index(sv, obj) >= 0) { - /* fprintf(stderr, "mutable variable, fetching CAR\n"); */ emit(bc, i, OP_CAR); } } @@ -424,15 +419,15 @@ void analyze_var_ref (sexp obj, sexp *bc, sexp_uint_t *i, sexp e, void analyze_app (sexp obj, sexp *bc, sexp_uint_t *i, sexp e, sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp) { sexp o1; - sexp_uint_t len = sexp_unbox_integer(sexp_length(SEXP_CDR(obj))); + sexp_uint_t len = sexp_unbox_integer(sexp_length(sexp_cdr(obj))); /* push the arguments onto the stack */ - for (o1 = sexp_reverse(SEXP_CDR(obj)); SEXP_PAIRP(o1); o1 = SEXP_CDR(o1)) { - analyze(SEXP_CAR(o1), bc, i, e, params, fv, sv, d, 0); + for (o1 = sexp_reverse(sexp_cdr(obj)); sexp_pairp(o1); o1 = sexp_cdr(o1)) { + analyze(sexp_car(o1), bc, i, e, params, fv, sv, d, 0); } /* push the operator onto the stack */ - analyze(SEXP_CAR(obj), bc, i, e, params, fv, sv, d, 0); + analyze(sexp_car(obj), bc, i, e, params, fv, sv, d, 0); /* maybe overwrite the current frame */ if (tailp) { @@ -450,24 +445,24 @@ void analyze_app (sexp obj, sexp *bc, sexp_uint_t *i, sexp e, sexp free_vars (sexp e, sexp formals, sexp obj, sexp fv) { sexp o1; - if (SEXP_SYMBOLP(obj)) { + if (sexp_symbolp(obj)) { if (env_global_p(e, obj) || (sexp_list_index(formals, obj) >= 0) || (sexp_list_index(fv, obj) >= 0)) return fv; else return sexp_cons(obj, fv); - } else if (SEXP_PAIRP(obj)) { - if (SEXP_SYMBOLP(SEXP_CAR(obj))) { - if ((o1 = env_cell(e, SEXP_CAR(obj))) - && SEXP_COREP(o1) - && (sexp_core_code(SEXP_CDR(o1)) == CORE_LAMBDA)) { - return free_vars(e, SEXP_CADR(obj), SEXP_CADDR(obj), fv); + } else if (sexp_pairp(obj)) { + if (sexp_symbolp(sexp_car(obj))) { + if ((o1 = env_cell(e, sexp_car(obj))) + && sexp_corep(o1) + && (sexp_core_code(sexp_cdr(o1)) == CORE_LAMBDA)) { + return free_vars(e, sexp_cadr(obj), sexp_caddr(obj), fv); } } - while (SEXP_PAIRP(obj)) { - fv = free_vars(e, formals, SEXP_CAR(obj), fv); - obj = SEXP_CDR(obj); + while (sexp_pairp(obj)) { + fv = free_vars(e, formals, sexp_car(obj), fv); + obj = sexp_cdr(obj); } return fv; } else { @@ -477,25 +472,25 @@ sexp free_vars (sexp e, sexp formals, sexp obj, sexp fv) { sexp set_vars (sexp e, sexp formals, sexp obj, sexp sv) { sexp tmp; - if (SEXP_NULLP(formals)) + if (sexp_nullp(formals)) return sv; - if (SEXP_PAIRP(obj)) { - if (SEXP_SYMBOLP(SEXP_CAR(obj))) { - if ((tmp = env_cell(e, SEXP_CAR(obj))) && SEXP_COREP(SEXP_CDR(tmp))) { - if (sexp_core_code(SEXP_CDR(tmp)) == CORE_LAMBDA) { - formals = sexp_lset_diff(formals, SEXP_CADR(obj)); - return set_vars(e, formals, SEXP_CADDR(obj), sv); - } else if (sexp_core_code(SEXP_CDR(tmp)) == CORE_SET - && (sexp_list_index(formals, SEXP_CADR(obj)) >= 0) - && ! (sexp_list_index(sv, SEXP_CADR(obj)) >= 0)) { - sv = sexp_cons(SEXP_CADR(obj), sv); - return set_vars(e, formals, SEXP_CADDR(obj), sv); + if (sexp_pairp(obj)) { + if (sexp_symbolp(sexp_car(obj))) { + if ((tmp = env_cell(e, sexp_car(obj))) && sexp_corep(sexp_cdr(tmp))) { + if (sexp_core_code(sexp_cdr(tmp)) == CORE_LAMBDA) { + formals = sexp_lset_diff(formals, sexp_cadr(obj)); + return set_vars(e, formals, sexp_caddr(obj), sv); + } else if (sexp_core_code(sexp_cdr(tmp)) == CORE_SET + && (sexp_list_index(formals, sexp_cadr(obj)) >= 0) + && ! (sexp_list_index(sv, sexp_cadr(obj)) >= 0)) { + sv = sexp_cons(sexp_cadr(obj), sv); + return set_vars(e, formals, sexp_caddr(obj), sv); } } } - while (SEXP_PAIRP(obj)) { - sv = set_vars(e, formals, SEXP_CAR(obj), sv); - obj = SEXP_CDR(obj); + while (sexp_pairp(obj)) { + sv = set_vars(e, formals, sexp_car(obj), sv); + obj = sexp_cdr(obj); } } return sv; @@ -520,8 +515,8 @@ void analyze_lambda (sexp name, sexp formals, sexp body, emit_push(bc, i, sexp_length(fv2)); emit(bc, i, OP_MAKE_VECTOR); (*d)++; - for (ls=fv2, k=0; SEXP_PAIRP(ls); ls=SEXP_CDR(ls), k++) { - analyze_var_ref(SEXP_CAR(ls), bc, i, e, params, fv, SEXP_NULL, d); + for (ls=fv2, k=0; sexp_pairp(ls); ls=sexp_cdr(ls), k++) { + analyze_var_ref(sexp_car(ls), bc, i, e, params, fv, SEXP_NULL, d); emit_push(bc, i, sexp_make_integer(k)); emit(bc, i, OP_STACK_REF); emit_word(bc, i, 3); @@ -575,8 +570,8 @@ sexp compile(sexp params, sexp obj, sexp e, sexp fv, sexp sv, int done_p) { sexp_bytecode_length(bc) = INIT_BCODE_SIZE; sexp_debug("set-vars: ", sv2); /* box mutable vars */ - for (ls=params; SEXP_PAIRP(ls); ls=SEXP_CDR(ls)) { - if ((j = sexp_list_index(sv2, SEXP_CAR(ls)) >= 0)) { + for (ls=params; sexp_pairp(ls); ls=sexp_cdr(ls)) { + if ((j = sexp_list_index(sv2, sexp_car(ls)) >= 0)) { emit_push(&bc, &i, SEXP_NULL); emit(&bc, &i, OP_STACK_REF); emit_word(&bc, &i, j+4); @@ -589,51 +584,51 @@ sexp compile(sexp params, sexp obj, sexp e, sexp fv, sexp sv, int done_p) { sv = sexp_append(sv2, sv); /* determine internal defines */ if (sexp_env_parent(e)) { - for (ls=SEXP_NULL; SEXP_PAIRP(obj); obj=SEXP_CDR(obj)) { - core = (SEXP_PAIRP(SEXP_CAR(obj)) && SEXP_SYMBOLP(SEXP_CAAR(obj)) - ? core_code(e, SEXP_CAAR(obj)) : 0); + for (ls=SEXP_NULL; sexp_pairp(obj); obj=sexp_cdr(obj)) { + core = (sexp_pairp(sexp_car(obj)) && sexp_symbolp(sexp_caar(obj)) + ? core_code(e, sexp_caar(obj)) : 0); if (core == CORE_BEGIN) { - obj = sexp_cons(SEXP_CAR(obj), - sexp_append(SEXP_CDAR(obj), SEXP_CDR(obj))); + obj = sexp_cons(sexp_car(obj), + sexp_append(sexp_cdar(obj), sexp_cdr(obj))); } else { if (core == CORE_DEFINE) { if (! define_ok) errx(1, "definition in non-definition context: %p", obj); - internals = sexp_cons(SEXP_PAIRP(SEXP_CADAR(obj)) - ? SEXP_CAR(SEXP_CADAR(obj)) : SEXP_CADAR(obj), + internals = sexp_cons(sexp_pairp(sexp_cadar(obj)) + ? sexp_car(sexp_cadar(obj)) : sexp_cadar(obj), internals); } else { define_ok = 0; } - ls = sexp_cons(SEXP_CAR(obj), ls); + ls = sexp_cons(sexp_car(obj), ls); } } obj = sexp_reverse(ls); j = sexp_unbox_integer(sexp_length(internals)); - if (SEXP_PAIRP(internals)) { + if (sexp_pairp(internals)) { /* sexp_write_string("internals: ", cur_error_port); */ /* sexp_write(internals, cur_error_port); */ /* sexp_write_string("\n", cur_error_port); */ e = extend_env_closure(e, internals, 2); params = sexp_append(internals, params); - for (ls=internals; SEXP_PAIRP(ls); ls=SEXP_CDR(ls)) + for (ls=internals; sexp_pairp(ls); ls=sexp_cdr(ls)) emit_push(&bc, &i, (sexp_uint_t) SEXP_UNDEF); d+=j; } } /* analyze body sequence */ - for ( ; SEXP_PAIRP(obj); obj=SEXP_CDR(obj)) { - if (SEXP_PAIRP(SEXP_CDR(obj))) { - analyze(SEXP_CAR(obj), &bc, &i, e, params, fv, sv, &d, 0); + for ( ; sexp_pairp(obj); obj=sexp_cdr(obj)) { + if (sexp_pairp(sexp_cdr(obj))) { + analyze(sexp_car(obj), &bc, &i, e, params, fv, sv, &d, 0); emit(&bc, &i, OP_DROP); d--; } else { - analyze(SEXP_CAR(obj), &bc, &i, e, params, fv, sv, &d, - (! done_p) && (! SEXP_PAIRP(internals)) + analyze(sexp_car(obj), &bc, &i, e, params, fv, sv, &d, + (! done_p) && (! sexp_pairp(internals)) ); } } - if (SEXP_PAIRP(internals)) { + if (sexp_pairp(internals)) { emit(&bc, &i, OP_STACK_SET); emit_word(&bc, &i, j+1); for (j; j>0; j--) @@ -689,7 +684,7 @@ sexp vm(sexp bc, sexp e, sexp* stack, sexp_sint_t top) { /* fprintf(stderr, " => "); */ /* sexp_write(SEXP_CDR(tmp1), cur_error_port); */ /* fprintf(stderr, "\n"); */ - stack[top++]=SEXP_CDR(tmp1); + stack[top++]=sexp_cdr(tmp1); ip += sizeof(sexp); break; case OP_GLOBAL_SET: @@ -767,43 +762,43 @@ sexp vm(sexp bc, sexp e, sexp* stack, sexp_sint_t top) { ip += sizeof(sexp); break; case OP_PAIRP: - stack[top-1]=SEXP_PAIRP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break; + stack[top-1]=sexp_pairp(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break; case OP_NULLP: - stack[top-1]=SEXP_NULLP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break; + stack[top-1]=sexp_nullp(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break; case OP_CHARP: - stack[top-1]=SEXP_CHARP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break; + stack[top-1]=sexp_charp(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break; case OP_INTEGERP: - stack[top-1]=SEXP_INTEGERP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break; + stack[top-1]=sexp_integerp(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break; case OP_SYMBOLP: - stack[top-1]=SEXP_SYMBOLP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break; + stack[top-1]=sexp_symbolp(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break; case OP_STRINGP: - stack[top-1]=SEXP_STRINGP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break; + stack[top-1]=sexp_stringp(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break; case OP_VECTORP: - stack[top-1]=SEXP_VECTORP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break; + stack[top-1]=sexp_vectorp(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break; case OP_PROCEDUREP: - stack[top-1]=SEXP_PROCEDUREP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break; + stack[top-1]=sexp_procedurep(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break; case OP_IPORTP: - stack[top-1]=SEXP_IPORTP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break; + stack[top-1]=sexp_iportp(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break; case OP_OPORTP: - stack[top-1]=SEXP_OPORTP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break; + stack[top-1]=sexp_oportp(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break; case OP_EOFP: stack[top-1]=(stack[top-1] == SEXP_EOF) ? SEXP_TRUE : SEXP_FALSE; break; case OP_CAR: /* print_stack(stack, top); */ - if (! SEXP_PAIRP(stack[top-1])) sexp_raise(sexp_intern("not-a-pair")); - stack[top-1]=SEXP_CAR(stack[top-1]); break; + if (! sexp_pairp(stack[top-1])) sexp_raise(sexp_intern("not-a-pair")); + stack[top-1]=sexp_car(stack[top-1]); break; case OP_CDR: - if (! SEXP_PAIRP(stack[top-1])) sexp_raise(sexp_intern("not-a-pair")); - stack[top-1]=SEXP_CDR(stack[top-1]); break; + if (! sexp_pairp(stack[top-1])) sexp_raise(sexp_intern("not-a-pair")); + stack[top-1]=sexp_cdr(stack[top-1]); break; case OP_SET_CAR: - if (! SEXP_PAIRP(stack[top-1])) sexp_raise(sexp_intern("not-a-pair")); - SEXP_CAR(stack[top-1]) = stack[top-2]; + if (! sexp_pairp(stack[top-1])) sexp_raise(sexp_intern("not-a-pair")); + sexp_car(stack[top-1]) = stack[top-2]; stack[top-2]=SEXP_UNDEF; top--; break; case OP_SET_CDR: - if (! SEXP_PAIRP(stack[top-1])) sexp_raise(sexp_intern("not-a-pair")); - SEXP_CDR(stack[top-1]) = stack[top-2]; + if (! sexp_pairp(stack[top-1])) sexp_raise(sexp_intern("not-a-pair")); + sexp_cdr(stack[top-1]) = stack[top-2]; stack[top-2]=SEXP_UNDEF; top--; break; @@ -873,11 +868,11 @@ sexp vm(sexp bc, sexp e, sexp* stack, sexp_sint_t top) { i = sexp_unbox_integer(((sexp*)ip)[0]); tmp1 = stack[top-1]; make_call: - if (SEXP_OPCODEP(tmp1)) + if (sexp_opcodep(tmp1)) /* hack, compile an opcode application on the fly */ tmp1 = make_opcode_procedure(tmp1, i, e); /* print_stack(stack, top); */ - if (! SEXP_PROCEDUREP(tmp1)) { + if (! sexp_procedurep(tmp1)) { fprintf(stderr, "error: non-procedure app: "); sexp_write(tmp1, cur_error_port); fprintf(stderr, "\n"); @@ -935,14 +930,14 @@ sexp vm(sexp bc, sexp e, sexp* stack, sexp_sint_t top) { tmp2 = stack[top-2]; i = sexp_unbox_integer(sexp_length(tmp2)); top += (i-2); - for ( ; SEXP_PAIRP(tmp2); tmp2=SEXP_CDR(tmp2), top--) - stack[top-1] = SEXP_CAR(tmp2); + for ( ; sexp_pairp(tmp2); tmp2=sexp_cdr(tmp2), top--) + stack[top-1] = sexp_car(tmp2); top += i+1; ip -= sizeof(sexp); goto make_call; case OP_CALLCC: tmp1 = stack[top-1]; - if (! SEXP_PROCEDUREP(tmp1)) + if (! sexp_procedurep(tmp1)) errx(2, "non-procedure application: %p", tmp1); stack[top] = sexp_make_integer(1); stack[top+1] = sexp_make_integer(ip); @@ -979,7 +974,7 @@ sexp vm(sexp bc, sexp e, sexp* stack, sexp_sint_t top) { sexp_write_string("ERROR: ", cur_error_port); sexp_write(stack[top-1], cur_error_port); sexp_write_string("\n", cur_error_port); - tmp1 = SEXP_CDR(exception_handler_cell); + tmp1 = sexp_cdr(exception_handler_cell); stack[top-1] = SEXP_UNDEF; stack[top] = (sexp) 1; stack[top+1] = sexp_make_integer(ip+4); @@ -1019,7 +1014,7 @@ sexp vm(sexp bc, sexp e, sexp* stack, sexp_sint_t top) { ip += ((signed char*)ip)[0]; break; case OP_DISPLAY: - if (SEXP_STRINGP(stack[top-1])) { + if (sexp_stringp(stack[top-1])) { sexp_write_string(sexp_string_data(stack[top-1]), stack[top-2]); break; } @@ -1098,7 +1093,7 @@ sexp sexp_close_port (sexp port) { sexp sexp_load (sexp source) { sexp obj, *stack=SEXP_ALLOC(sizeof(sexp)*INIT_STACK_SIZE); int closep = 0; - if (SEXP_STRINGP(source)) { + if (sexp_stringp(source)) { source = sexp_open_input_file(source); closep = 1; } diff --git a/sexp.c b/sexp.c index 837a1df6..745f3e87 100644 --- a/sexp.c +++ b/sexp.c @@ -53,11 +53,11 @@ static int symbol_table_count = 0; void sexp_free (sexp obj) { int len, i; sexp *elts; - if (SEXP_POINTERP(obj)) { + if (sexp_pointerp(obj)) { switch (obj->tag) { case SEXP_PAIR: - sexp_free(SEXP_CAR(obj)); - sexp_free(SEXP_CDR(obj)); + sexp_free(sexp_car(obj)); + sexp_free(sexp_cdr(obj)); break; case SEXP_VECTOR: len = sexp_vector_length(obj); @@ -81,60 +81,58 @@ void sexp_free (sexp obj) { sexp sexp_cons(sexp head, sexp tail) { sexp pair = SEXP_ALLOC(sexp_sizeof(pair)); pair->tag = SEXP_PAIR; -/* pair->data1 = (void*) head; */ -/* pair->data2 = (void*) tail; */ - SEXP_CAR(pair) = head; - SEXP_CDR(pair) = tail; + sexp_car(pair) = head; + sexp_cdr(pair) = tail; return pair; } int sexp_listp (sexp obj) { - while (SEXP_PAIRP(obj)) - obj = SEXP_CDR(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) + while (sexp_pairp(ls)) { + if (sexp_car(ls) == elt) return i; - ls = SEXP_CDR(ls); + ls = sexp_cdr(ls); i++; } return -1; } sexp sexp_memq (sexp x, sexp ls) { - while (SEXP_PAIRP(ls)) - if (x == SEXP_CAR(ls)) + while (sexp_pairp(ls)) + if (x == sexp_car(ls)) return ls; else - ls = SEXP_CDR(ls); + ls = sexp_cdr(ls); return SEXP_FALSE; } sexp sexp_assq (sexp x, sexp ls) { - while (SEXP_PAIRP(ls)) - if (x == SEXP_CAAR(ls)) + while (sexp_pairp(ls)) + if (x == sexp_caar(ls)) return ls; else - ls = SEXP_CDR(ls); + 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); + 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_reverse(sexp ls) { sexp res = SEXP_NULL; - for ( ; SEXP_PAIRP(ls); ls=SEXP_CDR(ls)) - res = sexp_cons(SEXP_CAR(ls), res); + for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) + res = sexp_cons(sexp_car(ls), res); return res; } @@ -142,29 +140,29 @@ sexp sexp_nreverse(sexp ls) { sexp a, b, tmp; if (ls == SEXP_NULL) { return ls; - } else if (! SEXP_PAIRP(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; + 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); + 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)) + for ( ; sexp_pairp(ls); res++, ls=sexp_cdr(ls)) ; return sexp_make_integer(res); } @@ -184,8 +182,6 @@ sexp sexp_make_string(char *str) { char *mystr = SEXP_ALLOC(len+1); memcpy(mystr, str, len+1); s->tag = SEXP_STRING; -/* s->data1 = (void*) len; */ -/* s->data2 = (void*) mystr; */ sexp_string_length(s) = len; sexp_string_data(s) = mystr; return s; @@ -250,8 +246,6 @@ sexp sexp_intern(char *str) { memcpy(mystr, str, len+1); mystr[len]=0; sym->tag = SEXP_SYMBOL; -/* sym->data1 = (void*) len; */ -/* sym->data2 = (void*) mystr; */ sexp_symbol_length(sym) = len; sexp_symbol_data(sym) = mystr; symbol_table[cell] = sym; @@ -268,8 +262,6 @@ sexp sexp_make_vector(sexp len, sexp dflt) { x[i] = dflt; } v->tag = SEXP_VECTOR; -/* v->data1 = (void*) clen; */ -/* v->data2 = (void*) x; */ sexp_vector_length(v) = clen; sexp_vector_data(v) = x; return v; @@ -279,8 +271,8 @@ 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); + for (i=0, x=ls; sexp_pairp(x); i++, x=sexp_cdr(x)) + elts[i] = sexp_car(x); return vec; } @@ -335,7 +327,6 @@ int sstream_close(void *vec) { sexp sexp_make_input_port(FILE* in) { sexp p = SEXP_ALLOC(sexp_sizeof(port)); p->tag = SEXP_IPORT; - /* p->data1 = in; */ sexp_port_stream(p) = in; return p; } @@ -343,7 +334,6 @@ sexp sexp_make_input_port(FILE* in) { sexp sexp_make_output_port(FILE* out) { sexp p = SEXP_ALLOC(sexp_sizeof(port)); p->tag = SEXP_OPORT; - /* p->data1 = out; */ sexp_port_stream(p) = out; return p; } @@ -371,16 +361,16 @@ void sexp_write (sexp obj, sexp out) { if (! obj) { sexp_write_string("#", out); - } else if (SEXP_POINTERP(obj)) { + } else if (sexp_pointerp(obj)) { switch (obj->tag) { 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(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); + sexp_write(sexp_car(x), out); } - if (! SEXP_NULLP(x)) { + if (! sexp_nullp(x)) { sexp_write_string(" . ", out); sexp_write(x, out); } @@ -438,15 +428,15 @@ void sexp_write (sexp obj, sexp out) { sexp_write_char('"', out); break; } - } else if (SEXP_INTEGERP(obj)) { + } else if (sexp_integerp(obj)) { sexp_printf(out, "%d", sexp_unbox_integer(obj)); - } else if (SEXP_CHARP(obj)) { + } else if (sexp_charp(obj)) { if (33 <= 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)) { + } else if (sexp_symbolp(obj)) { #if USE_HUFF_SYMS if (((sexp_uint_t)obj&7)==7) { @@ -564,7 +554,7 @@ sexp sexp_read_number(sexp in, int base) { return SEXP_ERROR; } tmp = sexp_read_float_tail(in, res); - if (negativep && SEXP_FLONUMP(tmp)) + if (negativep && sexp_flonump(tmp)) sexp_flonum_value(tmp) = -1 * sexp_flonum_value(tmp); return tmp; } else { @@ -634,7 +624,7 @@ sexp sexp_read_raw (sexp in) { } else { tmp2 = res; res = sexp_nreverse(res); - SEXP_CDR(tmp2) = tmp; + sexp_cdr(tmp2) = tmp; return res; } } @@ -794,8 +784,6 @@ void sexp_init() { the_unquote_splicing_symbol = sexp_intern("unquote-splicing"); the_empty_vector = SEXP_ALLOC(sexp_sizeof(vector)); the_empty_vector->tag = SEXP_VECTOR; -/* the_empty_vector->data1 = 0; */ -/* the_empty_vector->data2 = 0; */ sexp_vector_length(the_empty_vector) = 0; sexp_vector_data(the_empty_vector) = NULL; } diff --git a/sexp.h b/sexp.h index 04711802..f0d90bc0 100644 --- a/sexp.h +++ b/sexp.h @@ -162,31 +162,31 @@ struct sexp_struct { #define SEXP_CLOSE SEXP_MAKE_IMMEDIATE(6) /* internal use */ #define SEXP_RAWDOT SEXP_MAKE_IMMEDIATE(7) /* internal use */ -#define SEXP_NULLP(x) ((x) == SEXP_NULL) -#define SEXP_POINTERP(x) (((sexp_uint_t)(x) & SEXP_FIXNUM_MASK) == SEXP_POINTER_TAG) -#define SEXP_INTEGERP(x) (((sexp_uint_t)(x) & SEXP_FIXNUM_MASK) == SEXP_FIXNUM_TAG) -#define SEXP_ISYMBOLP(x) (((sexp_uint_t)(x) & SEXP_IMMEDIATE_MASK) == SEXP_ISYMBOL_TAG) -#define SEXP_CHARP(x) (((sexp_uint_t)(x) & SEXP_EXTENDED_MASK) == SEXP_CHAR_TAG) -#define SEXP_BOOLEANP(x) (((x) == SEXP_TRUE) || ((x) == SEXP_FALSE)) +#define sexp_nullp(x) ((x) == SEXP_NULL) +#define sexp_pointerp(x) (((sexp_uint_t)(x) & SEXP_FIXNUM_MASK) == SEXP_POINTER_TAG) +#define sexp_integerp(x) (((sexp_uint_t)(x) & SEXP_FIXNUM_MASK) == SEXP_FIXNUM_TAG) +#define sexp_isymbolp(x) (((sexp_uint_t)(x) & SEXP_IMMEDIATE_MASK) == SEXP_ISYMBOL_TAG) +#define sexp_charp(x) (((sexp_uint_t)(x) & SEXP_EXTENDED_MASK) == SEXP_CHAR_TAG) +#define sexp_booleanp(x) (((x) == SEXP_TRUE) || ((x) == SEXP_FALSE)) -#define SEXP_CHECK_TAG(x,t) (SEXP_POINTERP(x) && (x)->tag == (t)) +#define SEXP_CHECK_TAG(x,t) (sexp_pointerp(x) && (x)->tag == (t)) -#define SEXP_PAIRP(x) (SEXP_CHECK_TAG(x, SEXP_PAIR)) -#define SEXP_STRINGP(x) (SEXP_CHECK_TAG(x, SEXP_STRING)) -#define SEXP_LSYMBOLP(x) (SEXP_CHECK_TAG(x, SEXP_SYMBOL)) -#define SEXP_VECTORP(x) (SEXP_CHECK_TAG(x, SEXP_VECTOR)) -#define SEXP_FLONUMP(x) (SEXP_CHECK_TAG(x, SEXP_FLONUM)) -#define SEXP_IPORTP(x) (SEXP_CHECK_TAG(x, SEXP_IPORT)) -#define SEXP_OPORTP(x) (SEXP_CHECK_TAG(x, SEXP_OPORT)) -#define SEXP_EXCEPTIONP(x) (SEXP_CHECK_TAG(x, SEXP_EXCEPTION)) -#define SEXP_PROCEDUREP(x) (SEXP_CHECK_TAG(x, SEXP_PROCEDURE)) -#define SEXP_ENVP(x) (SEXP_CHECK_TAG(x, SEXP_ENV)) -#define SEXP_BYTECODEP(x) (SEXP_CHECK_TAG(x, SEXP_BYTECODE)) -#define SEXP_COREP(x) (SEXP_CHECK_TAG(x, SEXP_CORE)) -#define SEXP_OPCODEP(x) (SEXP_CHECK_TAG(x, SEXP_OPCODE)) -#define SEXP_MACROP(x) (SEXP_CHECK_TAG(x, SEXP_MACRO)) +#define sexp_pairp(x) (SEXP_CHECK_TAG(x, SEXP_PAIR)) +#define sexp_stringp(x) (SEXP_CHECK_TAG(x, SEXP_STRING)) +#define sexp_lsymbolp(x) (SEXP_CHECK_TAG(x, SEXP_SYMBOL)) +#define sexp_vectorp(x) (SEXP_CHECK_TAG(x, SEXP_VECTOR)) +#define sexp_flonump(x) (SEXP_CHECK_TAG(x, SEXP_FLONUM)) +#define sexp_iportp(x) (SEXP_CHECK_TAG(x, SEXP_IPORT)) +#define sexp_oportp(x) (SEXP_CHECK_TAG(x, SEXP_OPORT)) +#define sexp_exceptionp(x) (SEXP_CHECK_TAG(x, SEXP_EXCEPTION)) +#define sexp_procedurep(x) (SEXP_CHECK_TAG(x, SEXP_PROCEDURE)) +#define sexp_envp(x) (SEXP_CHECK_TAG(x, SEXP_ENV)) +#define sexp_bytecodep(x) (SEXP_CHECK_TAG(x, SEXP_BYTECODE)) +#define sexp_corep(x) (SEXP_CHECK_TAG(x, SEXP_CORE)) +#define sexp_opcodep(x) (SEXP_CHECK_TAG(x, SEXP_OPCODE)) +#define sexp_macrop(x) (SEXP_CHECK_TAG(x, SEXP_MACRO)) -#define SEXP_SYMBOLP(x) (SEXP_ISYMBOLP(x) || SEXP_LSYMBOLP(x)) +#define sexp_symbolp(x) (sexp_isymbolp(x) || sexp_lsymbolp(x)) #if USE_HUFF_SYMS #define SEXP_DOTP(x) (((sexp_uint_t)(x))==((0x5D00<value.pair.car) -#define SEXP_CDR(x) ((x)->value.pair.cdr) +#define sexp_car(x) ((x)->value.pair.car) +#define sexp_cdr(x) ((x)->value.pair.cdr) -#define SEXP_CAAR(x) (SEXP_CAR(SEXP_CAR(x))) -#define SEXP_CADR(x) (SEXP_CAR(SEXP_CDR(x))) -#define SEXP_CDAR(x) (SEXP_CDR(SEXP_CAR(x))) -#define SEXP_CDDR(x) (SEXP_CDR(SEXP_CDR(x))) +#define sexp_caar(x) (sexp_car(sexp_car(x))) +#define sexp_cadr(x) (sexp_car(sexp_cdr(x))) +#define sexp_cdar(x) (sexp_cdr(sexp_car(x))) +#define sexp_cddr(x) (sexp_cdr(sexp_cdr(x))) -#define SEXP_CAAAR(x) (SEXP_CAR(SEXP_CAAR(x))) -#define SEXP_CAADR(x) (SEXP_CAR(SEXP_CADR(x))) -#define SEXP_CADAR(x) (SEXP_CAR(SEXP_CDAR(x))) -#define SEXP_CADDR(x) (SEXP_CAR(SEXP_CDDR(x))) -#define SEXP_CDAAR(x) (SEXP_CDR(SEXP_CAAR(x))) -#define SEXP_CDADR(x) (SEXP_CDR(SEXP_CADR(x))) -#define SEXP_CDDAR(x) (SEXP_CDR(SEXP_CDAR(x))) -#define SEXP_CDDDR(x) (SEXP_CDR(SEXP_CDDR(x))) +#define sexp_caaar(x) (sexp_car(sexp_caar(x))) +#define sexp_caadr(x) (sexp_car(sexp_cadr(x))) +#define sexp_cadar(x) (sexp_car(sexp_cdar(x))) +#define sexp_caddr(x) (sexp_car(sexp_cddr(x))) +#define sexp_cdaar(x) (sexp_cdr(sexp_caar(x))) +#define sexp_cdadr(x) (sexp_cdr(sexp_cadr(x))) +#define sexp_cddar(x) (sexp_cdr(sexp_cdar(x))) +#define sexp_cdddr(x) (sexp_cdr(sexp_cddr(x))) -#define SEXP_CADDDR(x) (SEXP_CADR(SEXP_CDDR(x))) -#define SEXP_CDDDDR(x) (SEXP_CDDR(SEXP_CDDR(x))) +#define sexp_cadddr(x) (sexp_cadr(sexp_cddr(x))) +#define sexp_cddddr(x) (sexp_cddr(sexp_cddr(x))) sexp sexp_cons(sexp head, sexp tail); int sexp_listp(sexp obj); From 92aed1eda8941b9b7ae926bbdaf0d3ac3aa0990f Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 15 Mar 2009 21:39:36 +0900 Subject: [PATCH 040/154] removing warnings --- Makefile | 2 +- debug.c | 4 ++-- eval.c | 26 +++++++++++++------------- sexp.c | 20 ++++++++++---------- sexp.h | 8 ++++---- 5 files changed, 30 insertions(+), 30 deletions(-) diff --git a/Makefile b/Makefile index 9b7b6efd..8b85cd0b 100644 --- a/Makefile +++ b/Makefile @@ -3,7 +3,7 @@ all: chibi-scheme -CFLAGS=-g -fno-inline -save-temps -Os +CFLAGS=-Wall -g -fno-inline -save-temps -Os GC_OBJ=./gc/gc.a diff --git a/debug.c b/debug.c index 7526fa13..6e96b5b5 100644 --- a/debug.c +++ b/debug.c @@ -31,7 +31,7 @@ void disasm (sexp bc) { case OP_STACK_SET: case OP_CLOSURE_REF: case OP_PARAMETER: - fprintf(stderr, "%d", (long) ((sexp*)ip)[0]); + fprintf(stderr, "%ld", (long) ((sexp*)ip)[0]); ip += sizeof(sexp); break; case OP_GLOBAL_REF: @@ -62,7 +62,7 @@ void disasm (sexp bc) { void print_bytecode (sexp bc) { int i; unsigned char *data = sexp_bytecode_data(bc); - fprintf(stderr, "bytecode @ %p, data @ %p, length = %d\n", + fprintf(stderr, "bytecode @ %p, data @ %p, length = %lu\n", bc, data, sexp_bytecode_length(bc)); for (i=0; i+16 < sexp_bytecode_length(bc); i+=8) { fprintf(stderr, "%02x: %02x %02x %02x %02x %02x %02x %02x %02x ", i, diff --git a/eval.c b/eval.c index ff409d12..cc1d6d40 100644 --- a/eval.c +++ b/eval.c @@ -176,8 +176,8 @@ sexp sexp_expand_macro (sexp mac, sexp form, sexp e) { void analyze(sexp obj, sexp *bc, sexp_uint_t *i, sexp e, sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp) { - int tmp1, tmp2, tmp3; - sexp o1, o2, e2, cell; + int tmp1, tmp2; + sexp o1, o2, e2; loop: if (sexp_pairp(obj)) { @@ -269,7 +269,7 @@ void analyze(sexp obj, sexp *bc, sexp_uint_t *i, sexp e, (*d)++; break; default: - errx(1, "unknown core form: %s", sexp_core_code(o1)); + errx(1, "unknown core form: %d", sexp_core_code(o1)); } } else if (sexp_opcodep(o1)) { analyze_opcode(o1, obj, bc, i, e, params, fv, sv, d, tailp); @@ -305,14 +305,14 @@ void analyze(sexp obj, sexp *bc, sexp_uint_t *i, sexp e, emit(bc, i, OP_STACK_SET); emit_word(bc, i, tmp1+1); (*d) -= (tmp1-1); - for (tmp1; tmp1>0; tmp1--) + for ( ; tmp1>0; tmp1--) emit(bc, i, OP_DROP); } else #endif /* computed application */ analyze_app(obj, bc, i, e, params, fv, sv, d, tailp); } else { - errx(1, "invalid operator: %s", sexp_car(obj)); + errx(1, "invalid operator: %p", sexp_car(obj)); } } else if (sexp_symbolp(obj)) { analyze_var_ref(obj, bc, i, e, params, fv, sv, d); @@ -398,7 +398,7 @@ void analyze_var_ref (sexp obj, sexp *bc, sexp_uint_t *i, sexp e, o1 = env_cell(e, obj); fprintf(stderr, "compiling local ref: "); sexp_write(obj, cur_error_port); - fprintf(stderr, " => %d\n", *d - sexp_unbox_integer(sexp_cdr(o1))); + fprintf(stderr, " => %lu\n", *d - sexp_unbox_integer(sexp_cdr(o1))); emit(bc, i, OP_STACK_REF); emit_word(bc, i, *d - sexp_unbox_integer(sexp_cdr(o1))); } else if ((tmp = sexp_list_index(fv, obj)) >= 0) { @@ -563,7 +563,7 @@ sexp make_opcode_procedure(sexp op, sexp_uint_t i, sexp e) { } sexp compile(sexp params, sexp obj, sexp e, sexp fv, sexp sv, int done_p) { - sexp_uint_t i = 0, j, d = 0, core, define_ok=1; + sexp_uint_t i=0, j=0, d=0, define_ok=1, core; sexp bc = (sexp) SEXP_ALLOC(sexp_sizeof(bytecode)+INIT_BCODE_SIZE); sexp sv2 = set_vars(e, params, obj, SEXP_NULL), internals=SEXP_NULL, ls; bc->tag = SEXP_BYTECODE; @@ -631,7 +631,7 @@ sexp compile(sexp params, sexp obj, sexp e, sexp fv, sexp sv, int done_p) { if (sexp_pairp(internals)) { emit(&bc, &i, OP_STACK_SET); emit_word(&bc, &i, j+1); - for (j; j>0; j--) + for ( ; j>0; j--) emit(&bc, &i, OP_DROP); } emit(&bc, &i, done_p ? OP_DONE : OP_RET); @@ -864,7 +864,7 @@ sexp vm(sexp bc, sexp e, sexp* stack, sexp_sint_t top) { goto make_call; case OP_CALL: if (top >= INIT_STACK_SIZE) - errx(1, "out of stack space: %d", top); + errx(1, "out of stack space: %ld", top); i = sexp_unbox_integer(((sexp*)ip)[0]); tmp1 = stack[top-1]; make_call: @@ -880,7 +880,7 @@ sexp vm(sexp bc, sexp e, sexp* stack, sexp_sint_t top) { } j = i - sexp_unbox_integer(sexp_procedure_num_args(tmp1)); if (j < 0) { - fprintf(stderr, "error: expected %d args but got %d\n", + fprintf(stderr, "error: expected %ld args but got %ld\n", sexp_unbox_integer(sexp_procedure_num_args(tmp1)), i); sexp_raise(sexp_intern("not-enough-args")); @@ -895,7 +895,7 @@ sexp vm(sexp bc, sexp e, sexp* stack, sexp_sint_t top) { top -= (j-1); i-=(j-1); } else { - fprintf(stderr, "got: %d, expected: %d\n", i, sexp_procedure_num_args(tmp1)); + fprintf(stderr, "got: %ld, expected: %d\n", i, sexp_procedure_num_args(tmp1)); sexp_raise(sexp_intern("too-many-args")); } } else if (sexp_procedure_variadic_p(tmp1)) { @@ -1058,7 +1058,7 @@ sexp vm(sexp bc, sexp e, sexp* stack, sexp_sint_t top) { /* fprintf(stderr, "... done returning\n"); */ break; case OP_DONE: - fprintf(stderr, "finally returning @ %d: ", top-1); + fprintf(stderr, "finally returning @ %ld: ", top-1); fflush(stderr); sexp_write(stack[top-1], cur_error_port); fprintf(stderr, "\n"); @@ -1252,7 +1252,7 @@ void repl (sexp e, sexp *stack) { } int main (int argc, char **argv) { - sexp bc, e, obj, res, in, out, *stack, err_handler, err_handler_sym; + sexp bc, e, obj, res, *stack, err_handler, err_handler_sym; sexp_uint_t i, quit=0, init_loaded=0; scheme_init(); diff --git a/sexp.c b/sexp.c index 745f3e87..64ac1bf6 100644 --- a/sexp.c +++ b/sexp.c @@ -203,8 +203,8 @@ sexp sexp_intern(char *str) { #if USE_HUFF_SYMS res = 0; - for (p=str; c=*p; p++) { - he = huff_table[c]; + for ( ; (c=*p); p++) { + he = huff_table[(unsigned char)c]; newbits = he.len; if ((space+newbits) > (sizeof(sexp)*8)) { goto normal_intern; @@ -322,6 +322,7 @@ off_t sstream_seek(void *vec, off_t offset, int whence) { int sstream_close(void *vec) { sexp_free((sexp)vec); + return 0; } sexp sexp_make_input_port(FILE* in) { @@ -355,9 +356,9 @@ sexp sexp_get_output_string(sexp port) { void sexp_write (sexp obj, sexp out) { unsigned long len, c, res; - long i; + long i=0; sexp x, *elts; - char *str; + char *str=NULL; if (! obj) { sexp_write_string("#", out); @@ -429,13 +430,12 @@ void sexp_write (sexp obj, sexp out) { break; } } else if (sexp_integerp(obj)) { - sexp_printf(out, "%d", sexp_unbox_integer(obj)); + sexp_printf(out, "%ld", sexp_unbox_integer(obj)); } else if (sexp_charp(obj)) { - if (33 <= sexp_unbox_character(obj) < 127) { - sexp_printf(out, "#\\%c", sexp_unbox_character(obj)); - } else { - sexp_printf(out, "#\\x%02d", sexp_unbox_character(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 diff --git a/sexp.h b/sexp.h index f0d90bc0..d03aa309 100644 --- a/sexp.h +++ b/sexp.h @@ -194,10 +194,10 @@ struct sexp_struct { #define SEXP_DOTP(x) ((x)==sexp_the_dot_symbol) #endif -#define sexp_make_integer(n) ((sexp) (((sexp_sint_t) n<>SEXP_FIXNUM_BITS) -#define sexp_make_character(n) ((sexp) (((sexp_sint_t) n<>SEXP_EXTENDED_BITS) +#define sexp_make_integer(n) ((sexp) ((((sexp_sint_t)n)<>SEXP_FIXNUM_BITS) +#define sexp_make_character(n) ((sexp) ((((sexp_sint_t)n)<>SEXP_EXTENDED_BITS)) #define sexp_flonum_value(f) ((f)->value.flonum) From 3a8f46027cd2440f5b95a4516a2564c900401161 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 16 Mar 2009 01:07:31 +0900 Subject: [PATCH 041/154] cleaning up error handling, support flonum arith --- Makefile | 2 +- config.h | 29 ++- eval.c | 537 +++++++++++++++++++++++++++---------------------------- eval.h | 24 +-- sexp.c | 127 +++++++++---- sexp.h | 92 ++++------ 6 files changed, 417 insertions(+), 394 deletions(-) diff --git a/Makefile b/Makefile index 8b85cd0b..532a3cc2 100644 --- a/Makefile +++ b/Makefile @@ -23,7 +23,7 @@ chibi-scheme: eval.o sexp.o $(GC_OBJ) gcc $(CFLAGS) -o $@ $^ clean: - rm -f *.o + rm -f *.o *.i *.s cleaner: clean rm -f chibi-scheme diff --git a/config.h b/config.h index 297ab9c4..132d4211 100644 --- a/config.h +++ b/config.h @@ -2,22 +2,21 @@ /* Copyright (c) 2009 Alex Shinn. All rights reserved. */ /* BSD-style license: http://synthcode.com/license.txt */ -#ifndef USE_BOEHM -#define USE_BOEHM 1 -#endif +/* uncomment this to use manual memory management */ +/* #define USE_BOEHM 0 */ -#ifndef USE_HUFF_SYMS -#define USE_HUFF_SYMS 1 -#endif +/* uncomment this if you only want fixnum support */ +/* #define USE_FLONUMS 0 */ -#ifndef USE_DEBUG -#define USE_DEBUG 1 -#endif +/* uncomment this to disable huffman-coded immediate symbols */ +/* #define USE_HUFF_SYMS 0 */ -#ifndef USE_STRING_STREAMS -#define USE_STRING_STREAMS 1 -#endif +/* uncomment this to disable string ports */ +/* #define USE_STRING_STREAMS 0 */ + +/* uncomment this to disable a small optimization for let */ +/* #define USE_FAST_LET 0 */ + +/* uncomment this to enable debugging utilities */ +/* #define USE_DEBUG 1 */ -#ifndef USE_FAST_LET -#define USE_FAST_LET 1 -#endif diff --git a/eval.c b/eval.c index cc1d6d40..b555bf73 100644 --- a/eval.c +++ b/eval.c @@ -12,6 +12,7 @@ static sexp cur_input_port, cur_output_port, cur_error_port; static sexp exception_handler_cell; static sexp continuation_resumer; static sexp interaction_environment; +static sexp the_compile_error_symbol; #if USE_DEBUG #include "debug.c" @@ -150,12 +151,18 @@ static sexp sexp_make_macro (sexp p, sexp e) { /************************* the compiler ***************************/ +sexp sexp_compile_error(char *message, sexp irritants) { + return sexp_make_exception(the_compile_error_symbol, + sexp_make_string(message), + irritants, SEXP_FALSE, SEXP_FALSE); +} + sexp sexp_expand_macro (sexp mac, sexp form, sexp e) { sexp bc, res, *stack = SEXP_ALLOC(sizeof(sexp)*INIT_STACK_SIZE); sexp_uint_t i=0; - fprintf(stderr, "expanding: "); - sexp_write(form, cur_error_port); - fprintf(stderr, "\n => "); +/* fprintf(stderr, "expanding: "); */ +/* sexp_write(form, cur_error_port); */ +/* fprintf(stderr, "\n => "); */ bc = (sexp) SEXP_ALLOC(sexp_sizeof(bytecode)+64); bc->tag = SEXP_BYTECODE; sexp_bytecode_length(bc) = 32; @@ -167,36 +174,35 @@ sexp sexp_expand_macro (sexp mac, sexp form, sexp e) { emit_word(&bc, &i, (sexp_uint_t) sexp_make_integer(3)); emit(&bc, &i, OP_DONE); res = vm(bc, e, stack, 0); - sexp_write(res, cur_error_port); - fprintf(stderr, "\n"); +/* sexp_write(res, cur_error_port); */ +/* fprintf(stderr, "\n"); */ SEXP_FREE(bc); SEXP_FREE(stack); return res; } -void analyze(sexp obj, sexp *bc, sexp_uint_t *i, sexp e, +sexp analyze(sexp obj, sexp *bc, sexp_uint_t *i, sexp e, sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp) { int tmp1, tmp2; - sexp o1, o2, e2; + sexp o1, o2, e2, exn; loop: if (sexp_pairp(obj)) { if (sexp_symbolp(sexp_car(obj))) { o1 = env_cell(e, sexp_car(obj)); if (! o1) { - analyze_app(obj, bc, i, e, params, fv, sv, d, tailp); - return; + return analyze_app(obj, bc, i, e, params, fv, sv, d, tailp); } o1 = sexp_cdr(o1); if (sexp_corep(o1)) { switch (sexp_core_code(o1)) { case CORE_LAMBDA: - analyze_lambda(SEXP_FALSE, sexp_cadr(obj), sexp_cddr(obj), - bc, i, e, params, fv, sv, d, tailp); - break; + return analyze_lambda(SEXP_FALSE, sexp_cadr(obj), sexp_cddr(obj), + bc, i, e, params, fv, sv, d, tailp); case CORE_DEFINE_SYNTAX: - env_define(e, sexp_cadr(obj), - sexp_make_macro(eval(sexp_caddr(obj), e), e)); + o2 = eval(sexp_caddr(obj), e); + if (sexp_exceptionp(o2)) return o2; + env_define(e, sexp_cadr(obj), sexp_make_macro(o2, e)); emit_push(bc, i, SEXP_UNDEF); (*d)++; break; @@ -204,27 +210,30 @@ void analyze(sexp obj, sexp *bc, sexp_uint_t *i, sexp e, if ((sexp_core_code(o1) == CORE_DEFINE) && sexp_pairp(sexp_cadr(obj))) { o2 = sexp_car(sexp_cadr(obj)); - analyze_lambda(sexp_caadr(obj), sexp_cdadr(obj), sexp_cddr(obj), - bc, i, e, params, fv, sv, d, 0); + exn = analyze_lambda(sexp_caadr(obj), sexp_cdadr(obj), + sexp_cddr(obj), + bc, i, e, params, fv, sv, d, 0); } else { o2 = sexp_cadr(obj); - analyze(sexp_caddr(obj), bc, i, e, params, fv, sv, d, 0); + exn = analyze(sexp_caddr(obj), bc, i, e, params, fv, sv, d, 0); } + if (sexp_exceptionp(exn)) return exn; if (sexp_env_global_p(e)) { emit(bc, i, OP_GLOBAL_SET); emit_word(bc, i, (sexp_uint_t) o2); emit_push(bc, i, SEXP_UNDEF); } else { o1 = env_cell(e, o2); - if (! o1) - errx(1, "define in bad position: %p", o2); + return sexp_compile_error("define in bad position", + sexp_list1(obj)); emit(bc, i, OP_STACK_SET); emit_word(bc, i, sexp_unbox_integer(sexp_cdr(o1))); } (*d)++; break; case CORE_SET: - analyze(sexp_caddr(obj), bc, i, e, params, fv, sv, d, 0); + exn = analyze(sexp_caddr(obj), bc, i, e, params, fv, sv, d, 0); + if (sexp_exceptionp(exn)) return exn; if (sexp_list_index(sv, sexp_cadr(obj)) >= 0) { analyze_var_ref(sexp_cadr(obj), bc, i, e, params, fv, SEXP_NULL, d); emit(bc, i, OP_SET_CAR); @@ -235,29 +244,25 @@ void analyze(sexp obj, sexp *bc, sexp_uint_t *i, sexp e, } break; case CORE_BEGIN: - for (o2 = sexp_cdr(obj); sexp_pairp(o2); o2 = sexp_cdr(o2)) { - if (sexp_pairp(sexp_cdr(o2))) { - analyze(sexp_car(o2), bc, i, e, params, fv, sv, d, 0); - emit(bc, i, OP_DROP); - (*d)--; - } else - analyze(sexp_car(o2), bc, i, e, params, fv, sv, d, tailp); - } - break; + return + analyze_sequence(sexp_cdr(obj), bc, i, e, params, fv, sv, d, tailp); case CORE_IF: - analyze(sexp_cadr(obj), bc, i, e, params, fv, sv, d, 0); + exn = analyze(sexp_cadr(obj), bc, i, e, params, fv, sv, d, 0); + if (sexp_exceptionp(exn)) return exn; emit(bc, i, OP_JUMP_UNLESS); /* jumps if test fails */ (*d)--; tmp1 = *i; emit(bc, i, 0); - analyze(sexp_caddr(obj), bc, i, e, params, fv, sv, d, tailp); + exn = analyze(sexp_caddr(obj), bc, i, e, params, fv, sv, d, tailp); + if (sexp_exceptionp(exn)) return exn; emit(bc, i, OP_JUMP); (*d)--; tmp2 = *i; emit(bc, i, 0); ((signed char*) sexp_bytecode_data(*bc))[tmp1] = (*i)-tmp1; if (sexp_pairp(sexp_cdddr(obj))) { - analyze(sexp_cadddr(obj), bc, i, e, params, fv, sv, d, tailp); + exn = analyze(sexp_cadddr(obj), bc, i, e, params, fv, sv, d, tailp); + if (sexp_exceptionp(exn)) return exn; } else { emit_push(bc, i, SEXP_UNDEF); (*d)++; @@ -269,16 +274,17 @@ void analyze(sexp obj, sexp *bc, sexp_uint_t *i, sexp e, (*d)++; break; default: - errx(1, "unknown core form: %d", sexp_core_code(o1)); + return sexp_compile_error("unknown core form", sexp_list1(o1)); } } else if (sexp_opcodep(o1)) { - analyze_opcode(o1, obj, bc, i, e, params, fv, sv, d, tailp); + return analyze_opcode(o1, obj, bc, i, e, params, fv, sv, d, tailp); } else if (sexp_macrop(o1)) { obj = sexp_expand_macro(o1, obj, e); + if (sexp_exceptionp(obj)) return obj; goto loop; } else { /* general procedure call */ - analyze_app(obj, bc, i, e, params, fv, sv, d, tailp); + return analyze_app(obj, bc, i, e, params, fv, sv, d, tailp); } } else if (sexp_pairp(sexp_car(obj))) { #if USE_FAST_LET @@ -289,19 +295,18 @@ void analyze(sexp obj, sexp *bc, sexp_uint_t *i, sexp e, && sexp_listp(sexp_cadr(sexp_car(obj)))) { /* let */ tmp1 = sexp_unbox_integer(sexp_length(sexp_cadar(obj))); - e2 = extend_env_closure(e, sexp_cadar(obj), (*d)+(tmp1-1)); - for (o2=sexp_reverse(sexp_cdr(obj)); sexp_pairp(o2); o2=sexp_cdr(o2)) - analyze(sexp_car(o2), bc, i, e, params, fv, sv, d, 0); - params = sexp_append(sexp_cadar(obj), params); - for (o2=sexp_cddar(obj); sexp_pairp(o2); o2=sexp_cdr(o2)) { - if (sexp_pairp(sexp_cdr(o2))) { - analyze(sexp_car(o2), bc, i, e2, params, fv, sv, d, 0); - emit(bc, i, OP_DROP); - (*d)--; - } else { - analyze(sexp_car(o2), bc, i, e2, params, fv, sv, d, tailp); - } + /* push params as local stack variables */ + for (o2=sexp_reverse(sexp_cdr(obj)); sexp_pairp(o2); o2=sexp_cdr(o2)) { + exn = analyze(sexp_car(o2), bc, i, e, params, fv, sv, d, 0); + if (sexp_exceptionp(exn)) return exn; } + /* analyze the body in a new local env */ + e2 = extend_env_closure(e, sexp_cadar(obj), (*d)+(tmp1-1)); + params = sexp_append(sexp_cadar(obj), params); + exn = + analyze_sequence(sexp_cddar(obj), bc, i, e, params, fv, sv, d, tailp); + if (sexp_exceptionp(exn)) return exn; + /* set the result and pop off the local vars */ emit(bc, i, OP_STACK_SET); emit_word(bc, i, tmp1+1); (*d) -= (tmp1-1); @@ -310,9 +315,9 @@ void analyze(sexp obj, sexp *bc, sexp_uint_t *i, sexp e, } else #endif /* computed application */ - analyze_app(obj, bc, i, e, params, fv, sv, d, tailp); + return analyze_app(obj, bc, i, e, params, fv, sv, d, tailp); } else { - errx(1, "invalid operator: %p", sexp_car(obj)); + return sexp_compile_error("invalid operator", sexp_list1(sexp_car(obj))); } } else if (sexp_symbolp(obj)) { analyze_var_ref(obj, bc, i, e, params, fv, sv, d); @@ -320,13 +325,31 @@ void analyze(sexp obj, sexp *bc, sexp_uint_t *i, sexp e, emit_push(bc, i, obj); (*d)++; } + return SEXP_TRUE; } -void analyze_opcode (sexp op, sexp obj, sexp *bc, sexp_uint_t *i, sexp e, +sexp analyze_sequence (sexp ls, sexp *bc, sexp_uint_t *i, sexp e, + sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp) +{ + sexp exn; + for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) { + if (sexp_pairp(sexp_cdr(ls))) { + exn = analyze(sexp_car(ls), bc, i, e, params, fv, sv, d, 0); + if (sexp_exceptionp(exn)) return exn; + emit(bc, i, OP_DROP); + (*d)--; + } else { + analyze(sexp_car(ls), bc, i, e, params, fv, sv, d, tailp); + } + } + return SEXP_TRUE; +} + +sexp analyze_opcode (sexp op, sexp obj, sexp *bc, sexp_uint_t *i, sexp e, sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp) { int tmp1; - sexp o1; + sexp o1, exn; switch (sexp_opcode_class(op)) { case OPC_TYPE_PREDICATE: @@ -339,9 +362,10 @@ void analyze_opcode (sexp op, sexp obj, sexp *bc, sexp_uint_t *i, sexp e, case OPC_GENERIC: tmp1 = sexp_unbox_integer(sexp_length(sexp_cdr(obj))); if (tmp1 == 0) { - errx(1, "opcode with no arguments: %s", sexp_opcode_name(op)); + return sexp_compile_error("opcode with no arguments", sexp_list1(op)); } else if (tmp1 == 1) { - analyze(sexp_cadr(obj), bc, i, e, params, fv, sv, d, 0); + exn = analyze(sexp_cadr(obj), bc, i, e, params, fv, sv, d, 0); + if (sexp_exceptionp(exn)) return exn; if (sexp_opcode_class(op) == OPC_ARITHMETIC_INV) { emit(bc, i, sexp_opcode_inverse(op)); (*d)++; @@ -349,8 +373,10 @@ void analyze_opcode (sexp op, sexp obj, sexp *bc, sexp_uint_t *i, sexp e, emit(bc, i, sexp_opcode_code(op)); } } else { - for (o1=sexp_reverse(sexp_cdr(obj)); sexp_pairp(o1); o1=sexp_cdr(o1)) - analyze(sexp_car(o1), bc, i, e, params, fv, sv, d, 0); + for (o1=sexp_reverse(sexp_cdr(obj)); sexp_pairp(o1); o1=sexp_cdr(o1)) { + exn = analyze(sexp_car(o1), bc, i, e, params, fv, sv, d, 0); + if (sexp_exceptionp(exn)) return exn; + } emit(bc, i, sexp_opcode_code(op)); (*d) -= (tmp1-1); if (sexp_opcode_class(op) == OPC_ARITHMETIC) @@ -366,8 +392,10 @@ void analyze_opcode (sexp op, sexp obj, sexp *bc, sexp_uint_t *i, sexp e, (*d)++; tmp1++; } - for (o1=sexp_reverse(sexp_cdr(obj)); sexp_pairp(o1); o1=sexp_cdr(o1)) - analyze(sexp_car(o1), bc, i, e, params, fv, sv, d, 0); + for (o1=sexp_reverse(sexp_cdr(obj)); sexp_pairp(o1); o1=sexp_cdr(o1)) { + exn = analyze(sexp_car(o1), bc, i, e, params, fv, sv, d, 0); + if (sexp_exceptionp(exn)) return exn; + } emit(bc, i, sexp_opcode_code(op)); (*d) -= (tmp1-1); break; @@ -376,37 +404,32 @@ void analyze_opcode (sexp op, sexp obj, sexp *bc, sexp_uint_t *i, sexp e, emit_word(bc, i, (sexp_uint_t) sexp_opcode_data(op)); break; case OPC_FOREIGN: - for (o1=sexp_reverse(sexp_cdr(obj)); sexp_pairp(o1); o1=sexp_cdr(o1)) - analyze(sexp_car(o1), bc, i, e, params, fv, sv, d, 0); + for (o1=sexp_reverse(sexp_cdr(obj)); sexp_pairp(o1); o1=sexp_cdr(o1)) { + exn = analyze(sexp_car(o1), bc, i, e, params, fv, sv, d, 0); + if (sexp_exceptionp(exn)) return exn; + } emit_push(bc, i, sexp_opcode_data(op)); emit(bc, i, sexp_opcode_code(op)); (*d) -= (sexp_unbox_integer(sexp_length(sexp_cdr(obj)))-1); break; default: - errx(1, "unknown opcode class: %d", sexp_opcode_class(op)); + return sexp_compile_error("unknown opcode class", sexp_list1(op)); } + return SEXP_TRUE; } void analyze_var_ref (sexp obj, sexp *bc, sexp_uint_t *i, sexp e, sexp params, sexp fv, sexp sv, sexp_uint_t *d) { int tmp; sexp o1; -/* fprintf(stderr, "symbol lookup, param length: %d sv: ", length(params)); */ -/* sexp_write(sv, stderr); */ -/* fprintf(stderr, "\n"); */ if ((tmp = sexp_list_index(params, obj)) >= 0) { o1 = env_cell(e, obj); - fprintf(stderr, "compiling local ref: "); - sexp_write(obj, cur_error_port); - fprintf(stderr, " => %lu\n", *d - sexp_unbox_integer(sexp_cdr(o1))); emit(bc, i, OP_STACK_REF); emit_word(bc, i, *d - sexp_unbox_integer(sexp_cdr(o1))); } else if ((tmp = sexp_list_index(fv, obj)) >= 0) { - fprintf(stderr, "compiling closure ref: %p => %d\n", obj, tmp); emit(bc, i, OP_CLOSURE_REF); emit_word(bc, i, (sexp_uint_t) sexp_make_integer(tmp)); } else { - fprintf(stderr, "compiling global ref: %p\n", obj); emit(bc, i, OP_GLOBAL_REF); emit_word(bc, i, (sexp_uint_t) obj); } @@ -416,18 +439,20 @@ void analyze_var_ref (sexp obj, sexp *bc, sexp_uint_t *i, sexp e, } } -void analyze_app (sexp obj, sexp *bc, sexp_uint_t *i, sexp e, +sexp analyze_app (sexp obj, sexp *bc, sexp_uint_t *i, sexp e, sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp) { - sexp o1; + sexp o1, exn; sexp_uint_t len = sexp_unbox_integer(sexp_length(sexp_cdr(obj))); /* push the arguments onto the stack */ for (o1 = sexp_reverse(sexp_cdr(obj)); sexp_pairp(o1); o1 = sexp_cdr(o1)) { - analyze(sexp_car(o1), bc, i, e, params, fv, sv, d, 0); + exn = analyze(sexp_car(o1), bc, i, e, params, fv, sv, d, 0); + if (sexp_exceptionp(exn)) return exn; } /* push the operator onto the stack */ - analyze(sexp_car(obj), bc, i, e, params, fv, sv, d, 0); + exn = analyze(sexp_car(obj), bc, i, e, params, fv, sv, d, 0); + if (sexp_exceptionp(exn)) return exn; /* maybe overwrite the current frame */ if (tailp) { @@ -441,6 +466,7 @@ void analyze_app (sexp obj, sexp *bc, sexp_uint_t *i, sexp e, } (*d) -= (len); + return SEXP_TRUE; } sexp free_vars (sexp e, sexp formals, sexp obj, sexp fv) { @@ -496,7 +522,7 @@ sexp set_vars (sexp e, sexp formals, sexp obj, sexp sv) { return sv; } -void analyze_lambda (sexp name, sexp formals, sexp body, +sexp analyze_lambda (sexp name, sexp formals, sexp body, sexp *bc, sexp_uint_t *i, sexp e, sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp) { @@ -505,11 +531,9 @@ void analyze_lambda (sexp name, sexp formals, sexp body, flat_formals = sexp_flatten_dot(formals); fv2 = free_vars(e, flat_formals, body, SEXP_NULL); e2 = extend_env_closure(e, flat_formals, -4); -/* fprintf(stderr, "%d free-vars\n", sexp_length(fv2)); */ -/* sexp_write(fv2, cur_error_port); */ -/* fprintf(stderr, "\n"); */ /* compile the body with respect to the new params */ obj = compile(flat_formals, body, e2, fv2, sv, 0); + if (sexp_exceptionp(obj)) return obj; /* push the closed vars */ emit_push(bc, i, SEXP_UNDEF); emit_push(bc, i, sexp_length(fv2)); @@ -529,6 +553,7 @@ void analyze_lambda (sexp name, sexp formals, sexp body, emit_push(bc, i, sexp_length(formals)); emit_push(bc, i, sexp_make_integer(sexp_listp(formals) ? 0 : 1)); emit(bc, i, OP_MAKE_PROCEDURE); + return SEXP_TRUE; } sexp make_param_list(sexp_uint_t i) { @@ -568,7 +593,6 @@ sexp compile(sexp params, sexp obj, sexp e, sexp fv, sexp sv, int done_p) { sexp sv2 = set_vars(e, params, obj, SEXP_NULL), internals=SEXP_NULL, ls; bc->tag = SEXP_BYTECODE; sexp_bytecode_length(bc) = INIT_BCODE_SIZE; - sexp_debug("set-vars: ", sv2); /* box mutable vars */ for (ls=params; sexp_pairp(ls); ls=sexp_cdr(ls)) { if ((j = sexp_list_index(sv2, sexp_car(ls)) >= 0)) { @@ -592,8 +616,8 @@ sexp compile(sexp params, sexp obj, sexp e, sexp fv, sexp sv, int done_p) { sexp_append(sexp_cdar(obj), sexp_cdr(obj))); } else { if (core == CORE_DEFINE) { - if (! define_ok) - errx(1, "definition in non-definition context: %p", obj); + return sexp_compile_error("definition in non-definition context", + sexp_list1(obj)); internals = sexp_cons(sexp_pairp(sexp_cadar(obj)) ? sexp_car(sexp_cadar(obj)) : sexp_cadar(obj), internals); @@ -606,9 +630,6 @@ sexp compile(sexp params, sexp obj, sexp e, sexp fv, sexp sv, int done_p) { obj = sexp_reverse(ls); j = sexp_unbox_integer(sexp_length(internals)); if (sexp_pairp(internals)) { -/* sexp_write_string("internals: ", cur_error_port); */ -/* sexp_write(internals, cur_error_port); */ -/* sexp_write_string("\n", cur_error_port); */ e = extend_env_closure(e, internals, 2); params = sexp_append(internals, params); for (ls=internals; sexp_pairp(ls); ls=sexp_cdr(ls)) @@ -617,17 +638,8 @@ sexp compile(sexp params, sexp obj, sexp e, sexp fv, sexp sv, int done_p) { } } /* analyze body sequence */ - for ( ; sexp_pairp(obj); obj=sexp_cdr(obj)) { - if (sexp_pairp(sexp_cdr(obj))) { - analyze(sexp_car(obj), &bc, &i, e, params, fv, sv, &d, 0); - emit(&bc, &i, OP_DROP); - d--; - } else { - analyze(sexp_car(obj), &bc, &i, e, params, fv, sv, &d, - (! done_p) && (! sexp_pairp(internals)) - ); - } - } + analyze_sequence(obj, &bc, &i, e, params, fv, sv, &d, + (! done_p) && (! sexp_pairp(internals))); if (sexp_pairp(internals)) { emit(&bc, &i, OP_STACK_SET); emit_word(&bc, &i, j+1); @@ -636,8 +648,8 @@ sexp compile(sexp params, sexp obj, sexp e, sexp fv, sexp sv, int done_p) { } emit(&bc, &i, done_p ? OP_DONE : OP_RET); shrink_bcode(&bc, i); - print_bytecode(bc); - disasm(bc); +/* print_bytecode(bc); */ +/* disasm(bc); */ return bc; } @@ -661,7 +673,14 @@ sexp_uint_t sexp_restore_stack(sexp saved, sexp *current) { return len; } -#define sexp_raise(exn) {stack[top++]=(exn); goto call_error_handler;} +#define _ARG1 stack[top-1] +#define _ARG2 stack[top-2] +#define _ARG3 stack[top-3] +#define _ARG4 stack[top-4] +#define _PUSH(x) (stack[top++]=(x)) +#define _POP() (stack[--top]) + +#define sexp_raise(msg, args) {stack[top]=sexp_compile_error(msg, args); top++; goto call_error_handler;} sexp vm(sexp bc, sexp e, sexp* stack, sexp_sint_t top) { unsigned char *ip=sexp_bytecode_data(bc); @@ -677,174 +696,178 @@ sexp vm(sexp bc, sexp e, sexp* stack, sexp_sint_t top) { break; case OP_GLOBAL_REF: tmp1 = env_cell(e, ((sexp*)ip)[0]); - if (! tmp1) - sexp_raise(sexp_intern("undefined-variable")); -/* fprintf(stderr, "global-ref: "); */ -/* sexp_write(((sexp*)ip)[0], cur_error_port); */ -/* fprintf(stderr, " => "); */ -/* sexp_write(SEXP_CDR(tmp1), cur_error_port); */ -/* fprintf(stderr, "\n"); */ + if (! tmp1) sexp_raise("undefined-variable", sexp_list1(tmp1)); stack[top++]=sexp_cdr(tmp1); ip += sizeof(sexp); break; case OP_GLOBAL_SET: - env_define(e, ((sexp*)ip)[0], stack[--top]); + env_define(e, ((sexp*)ip)[0], _POP()); ip += sizeof(sexp); break; case OP_STACK_REF: -/* fprintf(stderr, "stack-ref: %d => ", (sexp_sint_t) ((sexp*)ip)[0]); */ -/* sexp_write(stack[top - (sexp_sint_t) ((sexp*)ip)[0]], cur_error_port); */ -/* fprintf(stderr, "\n"); */ -/* print_stack(stack, top); */ stack[top] = stack[top - (sexp_sint_t) ((sexp*)ip)[0]]; ip += sizeof(sexp); top++; break; case OP_STACK_SET: -/* print_stack(stack, top); */ -/* fprintf(stderr, "stack-set: %d => ", (sexp_sint_t) ((sexp*)ip)[0]); */ -/* sexp_write(stack[top-1], cur_error_port); */ -/* fprintf(stderr, "\n"); */ - stack[top - (sexp_sint_t) ((sexp*)ip)[0]] = stack[top-1]; - stack[top-1] = SEXP_UNDEF; -/* print_stack(stack, top); */ + stack[top - (sexp_sint_t) ((sexp*)ip)[0]] = _ARG1; + _ARG1 = SEXP_UNDEF; ip += sizeof(sexp); break; case OP_CLOSURE_REF: -/* fprintf(stderr, "closure-ref: %d => ", sexp_unbox_integer(((sexp*)ip)[0])); */ -/* sexp_write(sexp_vector_ref(cp, ((sexp*)ip)[0]), cur_error_port); */ -/* fprintf(stderr, "\n"); */ - stack[top++]=sexp_vector_ref(cp, ((sexp*)ip)[0]); + _PUSH(sexp_vector_ref(cp, ((sexp*)ip)[0])); ip += sizeof(sexp); break; case OP_VECTOR_REF: - stack[top-2]=sexp_vector_ref(stack[top-1], stack[top-2]); + _ARG2 = sexp_vector_ref(_ARG1, _ARG2); top--; break; case OP_VECTOR_SET: - sexp_vector_set(stack[top-1], stack[top-2], stack[top-3]); - stack[top-3]=SEXP_UNDEF; -/* fprintf(stderr, "vector-set: %d => ", sexp_unbox_integer(stack[top-2])); */ -/* sexp_write(stack[top-1], cur_error_port); */ -/* fprintf(stderr, "\n"); */ + sexp_vector_set(_ARG1, _ARG2, _ARG3); + _ARG3 = SEXP_UNDEF; top-=2; break; case OP_STRING_REF: - stack[top-2]=sexp_string_ref(stack[top-1], stack[top-2]); + _ARG2 = sexp_string_ref(_ARG1, _ARG2); top--; break; case OP_STRING_SET: - sexp_string_set(stack[top-1], stack[top-2], stack[top-3]); - stack[top-3]=SEXP_UNDEF; + sexp_string_set(_ARG1, _ARG2, _ARG3); + _ARG3 = SEXP_UNDEF; top-=2; break; case OP_MAKE_PROCEDURE: - stack[top-4]=sexp_make_procedure((int) stack[top-1], (int) stack[top-2], stack[top-3], stack[top-4]); + _ARG4 = sexp_make_procedure((int) _ARG1, (int) _ARG2, _ARG3, _ARG4); top-=3; break; case OP_MAKE_VECTOR: - stack[top-2]=sexp_make_vector(stack[top-1], stack[top-2]); + _ARG2 = sexp_make_vector(_ARG1, _ARG2); top--; break; case OP_PUSH: -/* fprintf(stderr, "pushing: "); */ -/* sexp_write(((sexp*)ip)[0], cur_error_port); */ -/* fprintf(stderr, "\n"); */ - stack[top++]=((sexp*)ip)[0]; + _PUSH(((sexp*)ip)[0]); ip += sizeof(sexp); break; case OP_DROP: top--; break; case OP_PARAMETER: - stack[top] = *(sexp*)((sexp*)ip)[0]; - top++; + _PUSH(*(sexp*)((sexp*)ip)[0]); ip += sizeof(sexp); break; case OP_PAIRP: - stack[top-1]=sexp_pairp(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break; + _ARG1 = sexp_make_boolean(sexp_pairp(_ARG1)); break; case OP_NULLP: - stack[top-1]=sexp_nullp(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break; + _ARG1 = sexp_make_boolean(sexp_nullp(_ARG1)); break; case OP_CHARP: - stack[top-1]=sexp_charp(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break; + _ARG1 = sexp_make_boolean(sexp_charp(_ARG1)); break; case OP_INTEGERP: - stack[top-1]=sexp_integerp(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break; + _ARG1 = sexp_make_boolean(sexp_integerp(_ARG1)); break; case OP_SYMBOLP: - stack[top-1]=sexp_symbolp(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break; + _ARG1 = sexp_make_boolean(sexp_symbolp(_ARG1)); break; case OP_STRINGP: - stack[top-1]=sexp_stringp(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break; + _ARG1 = sexp_make_boolean(sexp_stringp(_ARG1)); break; case OP_VECTORP: - stack[top-1]=sexp_vectorp(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break; + _ARG1 = sexp_make_boolean(sexp_vectorp(_ARG1)); break; case OP_PROCEDUREP: - stack[top-1]=sexp_procedurep(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break; + _ARG1 = sexp_make_boolean(sexp_procedurep(_ARG1)); break; case OP_IPORTP: - stack[top-1]=sexp_iportp(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break; + _ARG1 = sexp_make_boolean(sexp_iportp(_ARG1)); break; case OP_OPORTP: - stack[top-1]=sexp_oportp(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break; + _ARG1 = sexp_make_boolean(sexp_oportp(_ARG1)); break; case OP_EOFP: - stack[top-1]=(stack[top-1] == SEXP_EOF) ? SEXP_TRUE : SEXP_FALSE; break; + _ARG1 = sexp_make_boolean(_ARG1 == SEXP_EOF); break; case OP_CAR: - /* print_stack(stack, top); */ - if (! sexp_pairp(stack[top-1])) sexp_raise(sexp_intern("not-a-pair")); - stack[top-1]=sexp_car(stack[top-1]); break; + if (! sexp_pairp(_ARG1)) sexp_raise("not a pair", sexp_list1(_ARG1)); + _ARG1 = sexp_car(_ARG1); break; case OP_CDR: - if (! sexp_pairp(stack[top-1])) sexp_raise(sexp_intern("not-a-pair")); - stack[top-1]=sexp_cdr(stack[top-1]); break; + if (! sexp_pairp(_ARG1)) sexp_raise("not a pair", sexp_list1(_ARG1)); + _ARG1 = sexp_cdr(_ARG1); break; case OP_SET_CAR: - if (! sexp_pairp(stack[top-1])) sexp_raise(sexp_intern("not-a-pair")); - sexp_car(stack[top-1]) = stack[top-2]; - stack[top-2]=SEXP_UNDEF; + if (! sexp_pairp(_ARG1)) sexp_raise("not a pair", sexp_list1(_ARG1)); + sexp_car(_ARG1) = _ARG2; + _ARG2 = SEXP_UNDEF; top--; break; case OP_SET_CDR: - if (! sexp_pairp(stack[top-1])) sexp_raise(sexp_intern("not-a-pair")); - sexp_cdr(stack[top-1]) = stack[top-2]; - stack[top-2]=SEXP_UNDEF; + if (! sexp_pairp(_ARG1)) sexp_raise("not a pair", sexp_list1(_ARG1)); + sexp_cdr(_ARG1) = _ARG2; + _ARG2 = SEXP_UNDEF; top--; break; case OP_CONS: - stack[top-2]=sexp_cons(stack[top-1], stack[top-2]); + _ARG2 = sexp_cons(_ARG1, _ARG2); top--; break; case OP_ADD: - stack[top-2]=sexp_add(stack[top-1],stack[top-2]); + if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) + _ARG2 = sexp_fx_add(_ARG1, _ARG2); +#if USE_FLONUMS + else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_fp_add(_ARG1, _ARG2); + else if (sexp_flonump(_ARG1) && sexp_integerp(_ARG2)) + _ARG2 = sexp_fp_add(_ARG1, sexp_integer_to_flonum(_ARG2)); + else if (sexp_integerp(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_fp_add(sexp_integer_to_flonum(_ARG1), _ARG2); +#endif + else sexp_raise("not a number", sexp_list2(_ARG1, _ARG2)); top--; break; case OP_SUB: - stack[top-2]=sexp_sub(stack[top-1],stack[top-2]); + if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) + _ARG2 = sexp_fx_sub(_ARG1, _ARG2); +#if USE_FLONUMS + else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_fp_sub(_ARG1, _ARG2); + else if (sexp_flonump(_ARG1) && sexp_integerp(_ARG2)) + _ARG2 = sexp_fp_sub(_ARG1, sexp_integer_to_flonum(_ARG2)); + else if (sexp_integerp(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_fp_sub(sexp_integer_to_flonum(_ARG1), _ARG2); +#endif + else sexp_raise("not a number", sexp_list2(_ARG1, _ARG2)); top--; break; case OP_MUL: - stack[top-2]=sexp_mul(stack[top-1],stack[top-2]); + if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) + _ARG2 = sexp_fx_mul(_ARG1, _ARG2); +#if USE_FLONUMS + else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_fp_mul(_ARG1, _ARG2); + else if (sexp_flonump(_ARG1) && sexp_integerp(_ARG2)) + _ARG2 = sexp_fp_mul(_ARG1, sexp_integer_to_flonum(_ARG2)); + else if (sexp_integerp(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_fp_mul(sexp_integer_to_flonum(_ARG1), _ARG2); +#endif + else sexp_raise("not a number", sexp_list2(_ARG1, _ARG2)); top--; break; case OP_DIV: - stack[top-2]=sexp_div(stack[top-1],stack[top-2]); + _ARG2 = sexp_fx_div(_ARG1, _ARG2); top--; break; case OP_MOD: - stack[top-2]=sexp_mod(stack[top-1],stack[top-2]); + _ARG2 = sexp_fx_mod(_ARG1, _ARG2); top--; break; case OP_LT: - stack[top-2]=((stack[top-1] < stack[top-2]) ? SEXP_TRUE : SEXP_FALSE); + _ARG2 = sexp_make_boolean(_ARG1 < _ARG2); top--; break; case OP_LE: - stack[top-2]=((stack[top-1] <= stack[top-2]) ? SEXP_TRUE : SEXP_FALSE); + _ARG2 = sexp_make_boolean(_ARG1 <= _ARG2); top--; break; case OP_GT: - stack[top-2]=((stack[top-1] > stack[top-2]) ? SEXP_TRUE : SEXP_FALSE); + _ARG2 = sexp_make_boolean(_ARG1 > _ARG2); top--; break; case OP_GE: - stack[top-2]=((stack[top-1] >= stack[top-2]) ? SEXP_TRUE : SEXP_FALSE); + _ARG2 = sexp_make_boolean(_ARG1 >= _ARG2); top--; break; case OP_EQ: case OP_EQN: - stack[top-2]=((stack[top-1] == stack[top-2]) ? SEXP_TRUE : SEXP_FALSE); + _ARG2 = sexp_make_boolean(_ARG1 == _ARG2); top--; break; case OP_TAIL_CALL: @@ -853,7 +876,7 @@ sexp vm(sexp bc, sexp e, sexp* stack, sexp_sint_t top) { /* [==== i =====] */ j = sexp_unbox_integer(((sexp*)ip)[0]); /* current depth */ i = sexp_unbox_integer(((sexp*)ip)[1]); /* number of params */ - tmp1 = stack[top-1]; /* procedure to call */ + tmp1 = _ARG1; /* procedure to call */ /* save frame info */ ip = ((unsigned char*) sexp_unbox_integer(stack[top-i-3])) - sizeof(sexp); cp = stack[top-i-2]; @@ -864,27 +887,23 @@ sexp vm(sexp bc, sexp e, sexp* stack, sexp_sint_t top) { goto make_call; case OP_CALL: if (top >= INIT_STACK_SIZE) - errx(1, "out of stack space: %ld", top); + sexp_raise("out of stack space", SEXP_NULL); i = sexp_unbox_integer(((sexp*)ip)[0]); - tmp1 = stack[top-1]; + tmp1 = _ARG1; make_call: - if (sexp_opcodep(tmp1)) - /* hack, compile an opcode application on the fly */ + if (sexp_opcodep(tmp1)) { + /* compile non-inlined opcode applications on the fly */ tmp1 = make_opcode_procedure(tmp1, i, e); - /* print_stack(stack, top); */ - if (! sexp_procedurep(tmp1)) { - fprintf(stderr, "error: non-procedure app: "); - sexp_write(tmp1, cur_error_port); - fprintf(stderr, "\n"); - sexp_raise(sexp_intern("non-procedure-application")); + if (sexp_exceptionp(tmp1)) { + _ARG1 = tmp1; + goto call_error_handler; + } } + if (! sexp_procedurep(tmp1)) + sexp_raise("non procedure application", sexp_list1(tmp1)); j = i - sexp_unbox_integer(sexp_procedure_num_args(tmp1)); - if (j < 0) { - fprintf(stderr, "error: expected %ld args but got %ld\n", - sexp_unbox_integer(sexp_procedure_num_args(tmp1)), - i); - sexp_raise(sexp_intern("not-enough-args")); - } + if (j < 0) + sexp_raise("not enough args", sexp_list2(tmp1, sexp_make_integer(i))); if (j > 0) { if (sexp_procedure_variadic_p(tmp1)) { stack[top-i-1] = sexp_cons(stack[top-i-1], SEXP_NULL); @@ -895,8 +914,7 @@ sexp vm(sexp bc, sexp e, sexp* stack, sexp_sint_t top) { top -= (j-1); i-=(j-1); } else { - fprintf(stderr, "got: %ld, expected: %d\n", i, sexp_procedure_num_args(tmp1)); - sexp_raise(sexp_intern("too-many-args")); + sexp_raise("too many args", sexp_list2(tmp1, sexp_make_integer(i))); } } else if (sexp_procedure_variadic_p(tmp1)) { /* shift stack, set extra arg to null */ @@ -906,76 +924,51 @@ sexp vm(sexp bc, sexp e, sexp* stack, sexp_sint_t top) { top++; i++; } - stack[top-1] = sexp_make_integer(i); + _ARG1 = sexp_make_integer(i); stack[top] = sexp_make_integer(ip+sizeof(sexp)); stack[top+1] = cp; top+=2; -/* sexp_debug("call proc: ", tmp1); */ -/* sexp_debug("bc: ", sexp_procedure_code(tmp1)); */ -/* fprintf(stderr, "data: %p\n", sexp_procedure_code(tmp1)->data); */ bc = sexp_procedure_code(tmp1); -/* print_bytecode(bc); */ -/* disasm(bc); */ ip = sexp_bytecode_data(bc); cp = sexp_procedure_vars(tmp1); -/* fprintf(stderr, "... calling procedure at %p\ncp: ", ip); */ -/* /\* sexp_write(cp, stderr); *\/ */ -/* fprintf(stderr, "\n"); */ - /* fprintf(stderr, "stack at %d\n", top); */ - /* print_stack(stack, top); */ break; case OP_APPLY1: - /* print_stack(stack, top); */ - tmp1 = stack[top-1]; - tmp2 = stack[top-2]; + tmp1 = _ARG1; + tmp2 = _ARG2; i = sexp_unbox_integer(sexp_length(tmp2)); top += (i-2); for ( ; sexp_pairp(tmp2); tmp2=sexp_cdr(tmp2), top--) - stack[top-1] = sexp_car(tmp2); + _ARG1 = sexp_car(tmp2); top += i+1; ip -= sizeof(sexp); goto make_call; case OP_CALLCC: - tmp1 = stack[top-1]; - if (! sexp_procedurep(tmp1)) - errx(2, "non-procedure application: %p", tmp1); + tmp1 = _ARG1; + i = 1; stack[top] = sexp_make_integer(1); stack[top+1] = sexp_make_integer(ip); stack[top+2] = cp; -/* fprintf(stderr, "saved: ", top); */ -/* sexp_write(tmp2, cur_error_port); */ -/* fprintf(stderr, "\n", top); */ - stack[top-1] = sexp_make_procedure(0, (int) sexp_make_integer(1), - continuation_resumer, - sexp_vector(1, sexp_save_stack(stack, top+3))); - top+=3; - bc = sexp_procedure_code(tmp1); - ip = sexp_bytecode_data(bc); - cp = sexp_procedure_vars(tmp1); + _ARG1 + = sexp_make_procedure(0, (int) sexp_make_integer(1), + continuation_resumer, + sexp_vector(1, sexp_save_stack(stack, top+3))); + top++; + ip -= sizeof(sexp); + goto make_call; break; case OP_RESUMECC: -/* fprintf(stderr, "resuming continuation (%d)\n", top); */ -/* print_stack(stack, top); */ -/* sexp_write(sexp_vector_ref(cp, 0), cur_error_port); */ -/* fprintf(stderr, "\n"); */ - tmp1 = stack[top-4]; + tmp1 = _ARG4; top = sexp_restore_stack(sexp_vector_ref(cp, 0), stack); -/* fprintf(stderr, "... restored stack (%d):\n", top); */ -/* print_stack(stack, top); */ - cp = stack[top-1]; - ip = (unsigned char*) sexp_unbox_integer(stack[top-2]); - i = sexp_unbox_integer(stack[top-3]); + cp = _ARG1; + ip = (unsigned char*) sexp_unbox_integer(_ARG2); + i = sexp_unbox_integer(_ARG3); top -= 3; - stack[top-1] = tmp1; + _ARG1 = tmp1; break; case OP_ERROR: call_error_handler: - fprintf(stderr, "in error handler\n"); - sexp_write_string("ERROR: ", cur_error_port); - sexp_write(stack[top-1], cur_error_port); - sexp_write_string("\n", cur_error_port); tmp1 = sexp_cdr(exception_handler_cell); - stack[top-1] = SEXP_UNDEF; + _ARG1 = SEXP_UNDEF; stack[top] = (sexp) 1; stack[top+1] = sexp_make_integer(ip+4); stack[top+2] = cp; @@ -985,94 +978,81 @@ sexp vm(sexp bc, sexp e, sexp* stack, sexp_sint_t top) { cp = sexp_procedure_vars(tmp1); break; case OP_FCALL0: - stack[top-1]=((sexp_proc0)stack[top-1])(); + _ARG1 = ((sexp_proc0)_ARG1)(); + if (sexp_exceptionp(_ARG1)) goto call_error_handler; break; case OP_FCALL1: - stack[top-2]=((sexp_proc1)stack[top-1])(stack[top-2]); + _ARG2 = ((sexp_proc1)_ARG1)(_ARG2); top--; + if (sexp_exceptionp(_ARG1)) goto call_error_handler; break; case OP_FCALL2: - stack[top-3]=((sexp_proc2)stack[top-1])(stack[top-2],stack[top-3]); + _ARG3 = ((sexp_proc2)_ARG1)(_ARG2, _ARG3); top-=2; + if (sexp_exceptionp(_ARG1)) goto call_error_handler; break; case OP_FCALL3: - stack[top-4]=((sexp_proc3)stack[top-1])(stack[top-2],stack[top-3],stack[top-4]); + _ARG4 =((sexp_proc3)_ARG1)(_ARG2, _ARG3, _ARG4); top-=3; + if (sexp_exceptionp(_ARG1)) goto call_error_handler; break; case OP_JUMP_UNLESS: - /* fprintf(stderr, "JUMP UNLESS, stack top is %d\n", stack[top-1]); */ if (stack[--top] == SEXP_FALSE) { - /* fprintf(stderr, "test failed, jumping to + %d => %p\n", ((signed char*)ip)[0], ip + ((signed char*)ip)[0]); */ ip += ((signed char*)ip)[0]; } else { - /* fprintf(stderr, "test passed, not jumping\n"); */ ip++; } break; case OP_JUMP: - /* fprintf(stderr, "jumping to + %d => %p\n", ((signed char*)ip)[0], ip + ((signed char*)ip)[0]); */ ip += ((signed char*)ip)[0]; break; case OP_DISPLAY: - if (sexp_stringp(stack[top-1])) { - sexp_write_string(sexp_string_data(stack[top-1]), stack[top-2]); + if (sexp_stringp(_ARG1)) { + sexp_write_string(sexp_string_data(_ARG1), _ARG2); break; } case OP_WRITE: - sexp_write(stack[top-1], stack[top-2]); - stack[top-2] = SEXP_UNDEF; + sexp_write(_ARG1, _ARG2); + _ARG2 = SEXP_UNDEF; top--; break; case OP_WRITE_CHAR: - sexp_write_char(sexp_unbox_character(stack[top-1]), stack[top-2]); + sexp_write_char(sexp_unbox_character(_ARG1), _ARG2); break; case OP_NEWLINE: - sexp_write_char('\n', stack[top-1]); - stack[top-1] = SEXP_UNDEF; + sexp_write_char('\n', _ARG1); + _ARG1 = SEXP_UNDEF; break; case OP_FLUSH_OUTPUT: - sexp_flush(stack[top-1]); - stack[top-1] = SEXP_UNDEF; + sexp_flush(_ARG1); + _ARG1 = SEXP_UNDEF; break; case OP_READ: - stack[top-1] = sexp_read(stack[top-1]); - if (stack[top-1] == SEXP_ERROR) sexp_raise(sexp_intern("read-error")); + _ARG1 = sexp_read(_ARG1); + if (sexp_exceptionp(_ARG1)) goto call_error_handler; break; case OP_READ_CHAR: - i = sexp_read_char(stack[top-1]); - stack[top-1] = (i == EOF) ? SEXP_EOF : sexp_make_character(i); + i = sexp_read_char(_ARG1); + _ARG1 = (i == EOF) ? SEXP_EOF : sexp_make_character(i); break; case OP_RET: -/* fprintf(stderr, "returning @ %d: ", top-1); */ -/* fflush(stderr); */ -/* sexp_write(stack[top-1], cur_error_port); */ -/* fprintf(stderr, " ...\n"); */ - /* print_stack(stack, top); */ if (top<4) goto end_loop; - cp = stack[top-2]; - ip = (unsigned char*) sexp_unbox_integer(stack[top-3]); - i = sexp_unbox_integer(stack[top-4]); - stack[top-i-4] = stack[top-1]; + cp = _ARG2; + ip = (unsigned char*) sexp_unbox_integer(_ARG3); + i = sexp_unbox_integer(_ARG4); + stack[top-i-4] = _ARG1; top = top-i-3; -/* fprintf(stderr, "... done returning\n"); */ break; case OP_DONE: - fprintf(stderr, "finally returning @ %ld: ", top-1); - fflush(stderr); - sexp_write(stack[top-1], cur_error_port); - fprintf(stderr, "\n"); goto end_loop; default: - fprintf(stderr, "unknown opcode: %d\n", *(ip-1)); - stack[top] = SEXP_ERROR; - goto end_loop; + sexp_raise("unknown opcode", sexp_list1(sexp_make_integer(*(ip-1)))); } - /* print_stack(stack, top); */ goto loop; end_loop: - return stack[top-1]; + return _ARG1; } /************************ library procedures **************************/ @@ -1091,17 +1071,21 @@ sexp sexp_close_port (sexp port) { } sexp sexp_load (sexp source) { - sexp obj, *stack=SEXP_ALLOC(sizeof(sexp)*INIT_STACK_SIZE); + sexp obj, res, *stack=SEXP_ALLOC(sizeof(sexp)*INIT_STACK_SIZE); int closep = 0; if (sexp_stringp(source)) { source = sexp_open_input_file(source); closep = 1; } - while ((obj=sexp_read(source)) != (sexp) SEXP_EOF) - eval_in_stack(obj, interaction_environment, stack, 0); + while ((obj=sexp_read(source)) != (sexp) SEXP_EOF) { + res = eval_in_stack(obj, interaction_environment, stack, 0); + if (sexp_exceptionp(res)) goto done; + } + res = SEXP_UNDEF; + done: if (closep) sexp_close_port(source); SEXP_FREE(stack); - return SEXP_UNDEF; + return res; } /*********************** standard environment *************************/ @@ -1227,6 +1211,7 @@ void scheme_init() { cur_input_port = sexp_make_input_port(stdin); cur_output_port = sexp_make_output_port(stdout); cur_error_port = sexp_make_output_port(stderr); + the_compile_error_symbol = sexp_intern("compile-error"); bc = (sexp) SEXP_ALLOC(sexp_sizeof(bytecode)+16); bc->tag = SEXP_BYTECODE; sexp_bytecode_length(bc) = 16; diff --git a/eval.h b/eval.h index 8ad788b5..8a8e88d0 100644 --- a/eval.h +++ b/eval.h @@ -129,16 +129,20 @@ enum opcode_names { sexp compile(sexp params, sexp obj, sexp e, sexp fv, sexp sv, int done_p); -void analyze_app (sexp obj, sexp *bc, sexp_uint_t *i, - sexp e, sexp params, sexp fv, sexp sv, - sexp_uint_t *d, int tailp); -void analyze_lambda (sexp name, sexp formals, sexp body, - sexp *bc, sexp_uint_t *i, sexp e, - sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp); -void analyze_var_ref (sexp name, sexp *bc, sexp_uint_t *i, sexp e, - sexp params, sexp fv, sexp sv, sexp_uint_t *d); -void analyze_opcode (sexp op, sexp obj, sexp *bc, sexp_uint_t *i, sexp e, - sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp); +sexp analyze_app(sexp obj, sexp *bc, sexp_uint_t *i, + sexp e, sexp params, sexp fv, sexp sv, + sexp_uint_t *d, int tailp); +sexp analyze_lambda(sexp name, sexp formals, sexp body, + sexp *bc, sexp_uint_t *i, sexp e, + sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp); +void analyze_var_ref(sexp name, sexp *bc, sexp_uint_t *i, sexp e, + sexp params, sexp fv, sexp sv, sexp_uint_t *d); +sexp analyze_opcode(sexp op, sexp obj, sexp *bc, sexp_uint_t *i, sexp e, + sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp); +sexp analyze(sexp obj, sexp *bc, sexp_uint_t *i, sexp e, + sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp); +sexp analyze_sequence(sexp ls, sexp *bc, sexp_uint_t *i, sexp e, + sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp); sexp vm(sexp bc, sexp e, sexp* stack, sexp_sint_t top); sexp eval_in_stack(sexp expr, sexp e, sexp* stack, sexp_sint_t top); diff --git a/sexp.c b/sexp.c index 64ac1bf6..1adc48ea 100644 --- a/sexp.c +++ b/sexp.c @@ -23,6 +23,7 @@ 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[] = { @@ -76,6 +77,48 @@ void sexp_free (sexp obj) { } } +/***************************** exceptions *****************************/ + +sexp sexp_make_exception(sexp kind, sexp message, sexp irritants, + sexp file, sexp line) { + sexp exn = SEXP_ALLOC(sexp_sizeof(exception)); + exn->tag = 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_write_string("error", out); + if (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); + sexp_write_string("\n", out); + if (sexp_pairp(sexp_exception_irritants(exn))) { + sexp_write_string(" irritants: ", out); + sexp_write(sexp_exception_irritants(exn), 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) { @@ -325,20 +368,6 @@ int sstream_close(void *vec) { return 0; } -sexp sexp_make_input_port(FILE* in) { - sexp p = SEXP_ALLOC(sexp_sizeof(port)); - p->tag = SEXP_IPORT; - sexp_port_stream(p) = in; - return p; -} - -sexp sexp_make_output_port(FILE* out) { - sexp p = SEXP_ALLOC(sexp_sizeof(port)); - p->tag = SEXP_OPORT; - sexp_port_stream(p) = out; - return p; -} - 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); @@ -354,6 +383,22 @@ sexp sexp_get_output_string(sexp port) { #endif +sexp sexp_make_input_port(FILE* in) { + sexp p = SEXP_ALLOC(sexp_sizeof(port)); + p->tag = 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(sexp_sizeof(port)); + p->tag = 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; @@ -408,6 +453,8 @@ void sexp_write (sexp obj, sexp out) { sexp_write_string("#", out); break; case SEXP_ENV: sexp_write_string("#", out); break; + case SEXP_EXCEPTION: + sexp_write_string("#", out); break; case SEXP_MACRO: sexp_write_string("#", out); break; case SEXP_STRING: @@ -550,10 +597,10 @@ sexp sexp_read_number(sexp in, int base) { res = res * base + digit_value(c); if (c=='.') { if (base != 10) { - fprintf(stderr, "decimal found in non-base 10"); - return SEXP_ERROR; + 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; @@ -575,6 +622,7 @@ sexp sexp_read_raw (sexp in) { res = SEXP_EOF; break; case ';': + sexp_port_line(in)++; while ((c1 = sexp_read_char(in)) != EOF) if (c1 == '\n') break; @@ -582,7 +630,9 @@ sexp sexp_read_raw (sexp in) { case ' ': case '\t': case '\r': + goto scan_loop; case '\n': + sexp_port_line(in)++; goto scan_loop; case '\'': res = sexp_read(in); @@ -613,14 +663,14 @@ sexp sexp_read_raw (sexp in) { while ((tmp != SEXP_ERROR) && (tmp != SEXP_EOF) && (tmp != SEXP_CLOSE)) { if (tmp == SEXP_RAWDOT) { if (res == SEXP_NULL) { - fprintf(stderr, "sexp: dot before any elements in list\n"); - return SEXP_ERROR; + 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) { - fprintf(stderr, "sexp: multiple tokens in dotted tail\n"); sexp_free(res); - return SEXP_ERROR; + return sexp_read_error("multiple tokens in dotted tail", + SEXP_NULL, in); } else { tmp2 = res; res = sexp_nreverse(res); @@ -635,9 +685,9 @@ sexp sexp_read_raw (sexp in) { } if (tmp != SEXP_CLOSE) { sexp_free(res); - res = SEXP_ERROR; + return sexp_read_error("missing trailing ')'", SEXP_NULL, in); } - res = sexp_nreverse(res); + res = (sexp_pairp(res) ? sexp_nreverse(res) : res); break; case '#': switch (c1=sexp_read_char(in)) { @@ -657,8 +707,10 @@ sexp sexp_read_raw (sexp in) { if (c2 == EOF || is_separator(c2)) { res = (c1 == 't' ? SEXP_TRUE : SEXP_FALSE); } else { - fprintf(stderr, "sexp: invalid syntax #%c%c\n", c1, c2); - res = SEXP_ERROR; + 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; @@ -685,8 +737,9 @@ sexp sexp_read_raw (sexp in) { else if (strcasecmp(str, "tab") == 0) res = sexp_make_character('\t'); else { - fprintf(stderr, "unknown character name: '%s'\n", str); - res = SEXP_ERROR; + return sexp_read_error("unknown character name", + sexp_list1(sexp_make_string(str)), + in); } } break; @@ -694,19 +747,19 @@ sexp sexp_read_raw (sexp in) { sexp_push_char(c1, in); res = sexp_read(in); if (! sexp_listp(res)) { - if (res != SEXP_ERROR) { - fprintf(stderr, "sexp: dotted list not allowed in vector syntax\n"); + if (! sexp_exceptionp(res)) { sexp_free(res); - res = SEXP_ERROR; + return sexp_read_error("dotted list not allowed in vector syntax", + SEXP_NULL, + in); } } else { res = sexp_list_to_vector(res); } break; default: - fprintf(stderr, "sexp: invalid syntax #%c\n", c1); - res = SEXP_ERROR; - break; + return sexp_read_error("invalid # syntax", + sexp_list1(sexp_make_character(c1)), in); } break; case '.': @@ -732,7 +785,8 @@ sexp sexp_read_raw (sexp in) { if (c2 == '.' || isdigit(c2)) { sexp_push_char(c2, in); res = sexp_read_number(in, 10); - if (c1 == '-') res = sexp_mul(res, -1); + 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); @@ -756,8 +810,10 @@ sexp sexp_read_raw (sexp in) { sexp sexp_read (sexp in) { sexp res = sexp_read_raw(in); - if ((res == SEXP_CLOSE) || (res == SEXP_RAWDOT)) - res = SEXP_ERROR; + 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; } @@ -782,6 +838,7 @@ void sexp_init() { 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(sexp_sizeof(vector)); the_empty_vector->tag = SEXP_VECTOR; sexp_vector_length(the_empty_vector) = 0; diff --git a/sexp.h b/sexp.h index d03aa309..54bd0ffb 100644 --- a/sexp.h +++ b/sexp.h @@ -12,34 +12,7 @@ #include #include "config.h" - -#if HAVE_ERR_H -#include -#else -/* requires msg be a string literal, and at least one argument */ -#define errx(code, msg, ...) (fprintf(stderr,msg"\n",__VA_ARGS__), exit(code)) -#endif - -#if defined(__APPLE__) || defined(__FreeBSD__) || defined(__NetBSD__) || defined(__DragonFly__) || defined(__OpenBSD__) -#define SEXP_BSD 1 -#else -#define SEXP_BSD 0 -#endif - -#if USE_BOEHM -#include "gc/include/gc.h" -#define SEXP_ALLOC GC_malloc -#define SEXP_ALLOC_ATOMIC GC_malloc_atomic -#define SEXP_REALLOC GC_realloc -#define SEXP_FREE GC_free -#else -#define SEXP_ALLOC malloc -#define SEXP_ALLOC_ATOMIC SEXP_ALLOC -#define SEXP_REALLOC realloc -#define SEXP_FREE free -#endif - -#define SEXP_NEW() ((sexp) SEXP_ALLOC(sizeof(struct sexp_struct))) +#include "defaults.h" /* tagging system * bits end in 00: pointer @@ -60,7 +33,6 @@ #define SEXP_POINTER_TAG 0 #define SEXP_FIXNUM_TAG 1 -#define SEXP_LSYMBOL_TAG 3 #define SEXP_ISYMBOL_TAG 7 #define SEXP_CHAR_TAG 6 #define SEXP_EXTENDED_TAG 14 @@ -78,8 +50,8 @@ enum sexp_types { SEXP_BIGNUM, SEXP_IPORT, SEXP_OPORT, - /* the following are used only by the evaluator */ SEXP_EXCEPTION, + /* the following are used only by the evaluator */ SEXP_PROCEDURE, SEXP_MACRO, SEXP_ENV, @@ -158,7 +130,7 @@ struct sexp_struct { #define SEXP_TRUE SEXP_MAKE_IMMEDIATE(2) #define SEXP_EOF SEXP_MAKE_IMMEDIATE(3) #define SEXP_UNDEF SEXP_MAKE_IMMEDIATE(4) -#define SEXP_ERROR SEXP_MAKE_IMMEDIATE(5) +#define SEXP_ERROR SEXP_MAKE_IMMEDIATE(5) /* exceptions are preferred */ #define SEXP_CLOSE SEXP_MAKE_IMMEDIATE(6) /* internal use */ #define SEXP_RAWDOT SEXP_MAKE_IMMEDIATE(7) /* internal use */ @@ -171,36 +143,35 @@ struct sexp_struct { #define SEXP_CHECK_TAG(x,t) (sexp_pointerp(x) && (x)->tag == (t)) -#define sexp_pairp(x) (SEXP_CHECK_TAG(x, SEXP_PAIR)) -#define sexp_stringp(x) (SEXP_CHECK_TAG(x, SEXP_STRING)) -#define sexp_lsymbolp(x) (SEXP_CHECK_TAG(x, SEXP_SYMBOL)) -#define sexp_vectorp(x) (SEXP_CHECK_TAG(x, SEXP_VECTOR)) -#define sexp_flonump(x) (SEXP_CHECK_TAG(x, SEXP_FLONUM)) -#define sexp_iportp(x) (SEXP_CHECK_TAG(x, SEXP_IPORT)) -#define sexp_oportp(x) (SEXP_CHECK_TAG(x, SEXP_OPORT)) -#define sexp_exceptionp(x) (SEXP_CHECK_TAG(x, SEXP_EXCEPTION)) -#define sexp_procedurep(x) (SEXP_CHECK_TAG(x, SEXP_PROCEDURE)) -#define sexp_envp(x) (SEXP_CHECK_TAG(x, SEXP_ENV)) -#define sexp_bytecodep(x) (SEXP_CHECK_TAG(x, SEXP_BYTECODE)) -#define sexp_corep(x) (SEXP_CHECK_TAG(x, SEXP_CORE)) -#define sexp_opcodep(x) (SEXP_CHECK_TAG(x, SEXP_OPCODE)) -#define sexp_macrop(x) (SEXP_CHECK_TAG(x, SEXP_MACRO)) +#define sexp_pairp(x) (SEXP_CHECK_TAG(x, SEXP_PAIR)) +#define sexp_stringp(x) (SEXP_CHECK_TAG(x, SEXP_STRING)) +#define sexp_lsymbolp(x) (SEXP_CHECK_TAG(x, SEXP_SYMBOL)) +#define sexp_vectorp(x) (SEXP_CHECK_TAG(x, SEXP_VECTOR)) +#define sexp_flonump(x) (SEXP_CHECK_TAG(x, SEXP_FLONUM)) +#define sexp_iportp(x) (SEXP_CHECK_TAG(x, SEXP_IPORT)) +#define sexp_oportp(x) (SEXP_CHECK_TAG(x, SEXP_OPORT)) +#define sexp_exceptionp(x) (SEXP_CHECK_TAG(x, SEXP_EXCEPTION)) +#define sexp_procedurep(x) (SEXP_CHECK_TAG(x, SEXP_PROCEDURE)) +#define sexp_envp(x) (SEXP_CHECK_TAG(x, SEXP_ENV)) +#define sexp_bytecodep(x) (SEXP_CHECK_TAG(x, SEXP_BYTECODE)) +#define sexp_corep(x) (SEXP_CHECK_TAG(x, SEXP_CORE)) +#define sexp_opcodep(x) (SEXP_CHECK_TAG(x, SEXP_OPCODE)) +#define sexp_macrop(x) (SEXP_CHECK_TAG(x, SEXP_MACRO)) +#define sexp_symbolp(x) (sexp_isymbolp(x) || sexp_lsymbolp(x)) -#define sexp_symbolp(x) (sexp_isymbolp(x) || sexp_lsymbolp(x)) - -#if USE_HUFF_SYMS -#define SEXP_DOTP(x) (((sexp_uint_t)(x))==((0x5D00<>SEXP_FIXNUM_BITS) + #define sexp_make_character(n) ((sexp) ((((sexp_sint_t)n)<>SEXP_EXTENDED_BITS)) #define sexp_flonum_value(f) ((f)->value.flonum) +#define sexp_integer_to_flonum(x) (sexp_make_flonum(sexp_unbox_integer(x))) + #define sexp_vector_length(x) ((x)->value.vector.length) #define sexp_vector_data(x) ((x)->value.vector.data) @@ -281,11 +252,16 @@ void sexp_write_string(sexp str, sexp port); void sexp_printf(sexp port, sexp fmt, ...); #endif -#define sexp_add(a, b) ((sexp)(((sexp_sint_t)a)+((sexp_sint_t)b)-SEXP_FIXNUM_TAG)) -#define sexp_sub(a, b) ((sexp)(((sexp_sint_t)a)-((sexp_sint_t)b)+SEXP_FIXNUM_TAG)) -#define sexp_mul(a, b) ((sexp)((((((sexp_sint_t)a)-SEXP_FIXNUM_TAG)*(((sexp_sint_t)b)>>SEXP_FIXNUM_BITS))+SEXP_FIXNUM_TAG))) -#define sexp_div(a, b) ((sexp)(((((sexp_sint_t)a)>>SEXP_FIXNUM_BITS)/(((sexp_sint_t)b)>>SEXP_FIXNUM_BITS))<>SEXP_FIXNUM_BITS)%(((sexp_sint_t)b)>>SEXP_FIXNUM_BITS))<>SEXP_FIXNUM_BITS))+SEXP_FIXNUM_TAG))) +#define sexp_fx_div(a, b) ((sexp)(((((sexp_sint_t)a)>>SEXP_FIXNUM_BITS)/(((sexp_sint_t)b)>>SEXP_FIXNUM_BITS))<>SEXP_FIXNUM_BITS)%(((sexp_sint_t)b)>>SEXP_FIXNUM_BITS))< Date: Mon, 16 Mar 2009 02:52:48 +0900 Subject: [PATCH 042/154] simplifying opcode analysis --- debug.c | 2 +- eval.c | 170 ++++++++++++++++++++++------------------ eval.h | 1 + sexp.c | 3 +- sexp.h | 10 ++- tests/test00-fact-3.scm | 2 +- 6 files changed, 103 insertions(+), 85 deletions(-) diff --git a/debug.c b/debug.c index 6e96b5b5..cdc88778 100644 --- a/debug.c +++ b/debug.c @@ -12,7 +12,7 @@ static const char* reverse_opcode_names[] = "MAKE-VECTOR", "PUSH", "DROP", "PAIRP", "NULLP", "VECTORP", "INTEGERP", "SYMBOLP", "STRINGP", "CHARP", "EOFP", "PROCEDUREP", "IPORTP", "OPORTP", "CAR", "CDR", "SET-CAR", "SET-CDR", "CONS", "ADD", "SUB", "MUL", - "DIV", "MOD", "NEG", "INV", "LT", "LE", "GT", "GE", "EQN", "EQ", + "DIV", "QUOT", "MOD", "NEG", "INV", "LT", "LE", "GT", "GE", "EQN", "EQ", "DISPLAY", "WRITE", "WRITE-CHAR", "NEWLINE", "FLUSH-OUTPUT", "READ", "READ-CHAR", }; diff --git a/eval.c b/eval.c index b555bf73..97f2a5b2 100644 --- a/eval.c +++ b/eval.c @@ -348,73 +348,56 @@ sexp analyze_sequence (sexp ls, sexp *bc, sexp_uint_t *i, sexp e, sexp analyze_opcode (sexp op, sexp obj, sexp *bc, sexp_uint_t *i, sexp e, sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp) { - int tmp1; - sexp o1, exn; + sexp ls, exn; + int j, len = sexp_unbox_integer(sexp_length(sexp_cdr(obj))); - switch (sexp_opcode_class(op)) { - case OPC_TYPE_PREDICATE: - case OPC_PREDICATE: - case OPC_ARITHMETIC: - case OPC_ARITHMETIC_INV: - case OPC_ARITHMETIC_CMP: - case OPC_CONSTRUCTOR: - case OPC_ACCESSOR: - case OPC_GENERIC: - tmp1 = sexp_unbox_integer(sexp_length(sexp_cdr(obj))); - if (tmp1 == 0) { - return sexp_compile_error("opcode with no arguments", sexp_list1(op)); - } else if (tmp1 == 1) { - exn = analyze(sexp_cadr(obj), bc, i, e, params, fv, sv, d, 0); - if (sexp_exceptionp(exn)) return exn; - if (sexp_opcode_class(op) == OPC_ARITHMETIC_INV) { - emit(bc, i, sexp_opcode_inverse(op)); - (*d)++; - } else if (sexp_opcode_class(op) != OPC_ARITHMETIC) { - emit(bc, i, sexp_opcode_code(op)); - } - } else { - for (o1=sexp_reverse(sexp_cdr(obj)); sexp_pairp(o1); o1=sexp_cdr(o1)) { - exn = analyze(sexp_car(o1), bc, i, e, params, fv, sv, d, 0); - if (sexp_exceptionp(exn)) return exn; - } - emit(bc, i, sexp_opcode_code(op)); - (*d) -= (tmp1-1); - if (sexp_opcode_class(op) == OPC_ARITHMETIC) - for (tmp1-=2; tmp1>0; tmp1--) - emit(bc, i, sexp_opcode_code(op)); - } - break; - case OPC_IO: - tmp1 = sexp_unbox_integer(sexp_length(sexp_cdr(obj))); - if (tmp1 == sexp_opcode_num_args(op) && sexp_opcode_variadic_p(op)) { - emit(bc, i, OP_PARAMETER); - emit_word(bc, i, (sexp_uint_t) sexp_opcode_data(op)); - (*d)++; - tmp1++; - } - for (o1=sexp_reverse(sexp_cdr(obj)); sexp_pairp(o1); o1=sexp_cdr(o1)) { - exn = analyze(sexp_car(o1), bc, i, e, params, fv, sv, d, 0); - if (sexp_exceptionp(exn)) return exn; - } - emit(bc, i, sexp_opcode_code(op)); - (*d) -= (tmp1-1); - break; - case OPC_PARAMETER: - emit(bc, i, sexp_opcode_code(op)); + /* verify parameters */ + if (len < sexp_opcode_num_args(op)) { + return sexp_compile_error("not enough arguments", sexp_list1(obj)); + } else if (len > sexp_opcode_num_args(op)) { + if (! sexp_opcode_variadic_p(op)) + return sexp_compile_error("too many arguments", sexp_list1(obj)); + } else if (sexp_opcode_variadic_p(op) && sexp_opcode_data(op)) { + fprintf(stderr, "compiling parameter: %p for op %s\n", + sexp_opcode_data(op), sexp_opcode_name(op)); + emit(bc, i, OP_PARAMETER); emit_word(bc, i, (sexp_uint_t) sexp_opcode_data(op)); - break; - case OPC_FOREIGN: - for (o1=sexp_reverse(sexp_cdr(obj)); sexp_pairp(o1); o1=sexp_cdr(o1)) { - exn = analyze(sexp_car(o1), bc, i, e, params, fv, sv, d, 0); - if (sexp_exceptionp(exn)) return exn; + if (! sexp_opcode_opt_param_p(op)) { + emit(bc, i, OP_CALL); + emit_word(bc, i, (sexp_uint_t) sexp_make_integer(0)); } - emit_push(bc, i, sexp_opcode_data(op)); - emit(bc, i, sexp_opcode_code(op)); - (*d) -= (sexp_unbox_integer(sexp_length(sexp_cdr(obj)))-1); - break; - default: - return sexp_compile_error("unknown opcode class", sexp_list1(op)); + (*d)++; + len++; } + + /* push arguments */ + for (ls=sexp_reverse(sexp_cdr(obj)); sexp_pairp(ls); ls=sexp_cdr(ls)) { + exn = analyze(sexp_car(ls), bc, i, e, params, fv, sv, d, 0); + if (sexp_exceptionp(exn)) return exn; + } + + /* emit operator */ + if (sexp_opcode_class(op) == OPC_ARITHMETIC_INV) { + emit(bc, i, (len == 1) ? sexp_opcode_inverse(op) : sexp_opcode_code(op)); + } else { + if (sexp_opcode_class(op) == OPC_FOREIGN) + emit_push(bc, i, sexp_opcode_data(op)); + emit(bc, i, sexp_opcode_inverse(op) ? sexp_opcode_inverse(op) + : sexp_opcode_code(op)); + } + + /* emit optional multiple copies of operator */ + if ((len > 1) + && (sexp_opcode_class(op) == OPC_ARITHMETIC + || sexp_opcode_class(op) == OPC_ARITHMETIC_INV)) + for (j=len-2; j>0; j--) + emit(bc, i, sexp_opcode_code(op)); + + if (sexp_opcode_class(op) == OPC_PARAMETER) + emit_word(bc, i, (sexp_uint_t) sexp_opcode_data(op)); + + (*d) -= (len-1); + return SEXP_TRUE; } @@ -648,8 +631,8 @@ sexp compile(sexp params, sexp obj, sexp e, sexp fv, sexp sv, int done_p) { } emit(&bc, &i, done_p ? OP_DONE : OP_RET); shrink_bcode(&bc, i); -/* print_bytecode(bc); */ -/* disasm(bc); */ + /* print_bytecode(bc); */ + /* disasm(bc); */ return bc; } @@ -680,7 +663,7 @@ sexp_uint_t sexp_restore_stack(sexp saved, sexp *current) { #define _PUSH(x) (stack[top++]=(x)) #define _POP() (stack[--top]) -#define sexp_raise(msg, args) {stack[top]=sexp_compile_error(msg, args); top++; goto call_error_handler;} +#define sexp_raise(msg, args) do {stack[top]=sexp_compile_error(msg, args); top++; goto call_error_handler;} while (0) sexp vm(sexp bc, sexp e, sexp* stack, sexp_sint_t top) { unsigned char *ip=sexp_bytecode_data(bc); @@ -842,12 +825,42 @@ sexp vm(sexp bc, sexp e, sexp* stack, sexp_sint_t top) { top--; break; case OP_DIV: - _ARG2 = sexp_fx_div(_ARG1, _ARG2); + if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) + _ARG2 = sexp_fp_div(sexp_integer_to_flonum(_ARG1), + sexp_integer_to_flonum(_ARG2)); +#if USE_FLONUMS + else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_fp_div(_ARG1, _ARG2); + else if (sexp_flonump(_ARG1) && sexp_integerp(_ARG2)) + _ARG2 = sexp_fp_div(_ARG1, sexp_integer_to_flonum(_ARG2)); + else if (sexp_integerp(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_fp_div(sexp_integer_to_flonum(_ARG1), _ARG2); +#endif + else sexp_raise("not a number", sexp_list2(_ARG1, _ARG2)); top--; break; + case OP_QUOT: + if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) { + _ARG2 = sexp_fx_div(_ARG1, _ARG2); + top--; + } + else sexp_raise("not a number", sexp_list2(_ARG1, _ARG2)); + break; case OP_MOD: - _ARG2 = sexp_fx_mod(_ARG1, _ARG2); - top--; + if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) { + _ARG2 = sexp_fx_mod(_ARG1, _ARG2); + top--; + } + else sexp_raise("not a number", sexp_list2(_ARG1, _ARG2)); + break; + case OP_NEG: + if (sexp_integerp(_ARG1)) + _ARG1 = sexp_make_integer(-sexp_unbox_integer(_ARG1)); +#if USE_FLONUMS + else if (sexp_flonump(_ARG1)) + _ARG1 = sexp_make_flonum(-sexp_flonum_value(_ARG1)); +#endif + else sexp_raise("not a number", sexp_list2(_ARG1, _ARG2)); break; case OP_LT: _ARG2 = sexp_make_boolean(_ARG1 < _ARG2); @@ -967,8 +980,8 @@ sexp vm(sexp bc, sexp e, sexp* stack, sexp_sint_t top) { break; case OP_ERROR: call_error_handler: + sexp_print_exception(_ARG1, cur_error_port); tmp1 = sexp_cdr(exception_handler_cell); - _ARG1 = SEXP_UNDEF; stack[top] = (sexp) 1; stack[top+1] = sexp_make_integer(ip+4); stack[top+2] = cp; @@ -1121,7 +1134,8 @@ _OP(OPC_ARITHMETIC, OP_ADD, 0, 1, SEXP_FIXNUM, 0, 0, "+", NULL, NULL), _OP(OPC_ARITHMETIC, OP_MUL, 0, 1, SEXP_FIXNUM, 0, 0, "*", NULL, NULL), _OP(OPC_ARITHMETIC_INV, OP_SUB, 0, 1, SEXP_FIXNUM, 0, OP_NEG, "-", NULL, NULL), _OP(OPC_ARITHMETIC_INV, OP_DIV, 0, 1, SEXP_FIXNUM, 0, OP_INV, "/", NULL, NULL), -_OP(OPC_ARITHMETIC, OP_MOD, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, 0, "%", NULL, NULL), +_OP(OPC_ARITHMETIC, OP_QUOT, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, 0, "quotient", NULL, NULL), +_OP(OPC_ARITHMETIC, OP_MOD, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, 0, "modulo", NULL, NULL), _OP(OPC_ARITHMETIC_CMP, OP_LT, 0, 1, SEXP_FIXNUM, 0, 0, "<", NULL, NULL), _OP(OPC_ARITHMETIC_CMP, OP_LE, 0, 1, SEXP_FIXNUM, 0, 0, "<=", NULL, NULL), _OP(OPC_ARITHMETIC_CMP, OP_GT, 0, 1, SEXP_FIXNUM, 0, 0, ">", NULL, NULL), @@ -1144,13 +1158,13 @@ _OP(OPC_TYPE_PREDICATE, OP_EOFP, 1, 0, 0, 0, 0, "eof-object?", NULL, NULL), _OP(OPC_GENERIC, OP_APPLY1, 2, 0, SEXP_PROCEDURE, SEXP_PAIR, 0, "apply1", NULL, NULL), _OP(OPC_GENERIC, OP_CALLCC, 1, SEXP_PROCEDURE, 0, 0, 0, "call-with-current-continuation", NULL, NULL), _OP(OPC_GENERIC, OP_ERROR, 1, SEXP_STRING, 0, 0, 0, "error", NULL, NULL), -_OP(OPC_IO, OP_WRITE, 1, 1, 0, SEXP_OPORT, 0, "write", (sexp)&cur_output_port, NULL), -_OP(OPC_IO, OP_DISPLAY, 1, 1, 0, SEXP_OPORT, 0, "display", (sexp)&cur_output_port, NULL), -_OP(OPC_IO, OP_WRITE_CHAR, 1, 1, 0, SEXP_OPORT, 0, "write-char", (sexp)&cur_output_port, NULL), -_OP(OPC_IO, OP_NEWLINE, 0, 1, 0, SEXP_OPORT, 0, "newline", (sexp)&cur_output_port, NULL), -_OP(OPC_IO, OP_FLUSH_OUTPUT, 0, 1, 0, SEXP_OPORT, 0, "flush-output", (sexp)&cur_output_port, NULL), -_OP(OPC_IO, OP_READ, 0, 1, 0, SEXP_IPORT, 0, "read", (sexp)&cur_input_port, NULL), -_OP(OPC_IO, OP_READ_CHAR, 0, 1, 0, SEXP_IPORT, 0, "read-char", (sexp)&cur_input_port, NULL), +_OP(OPC_IO, OP_WRITE, 1, 3, 0, SEXP_OPORT, 0, "write", (sexp)&cur_output_port, NULL), +_OP(OPC_IO, OP_DISPLAY, 1, 3, 0, SEXP_OPORT, 0, "display", (sexp)&cur_output_port, NULL), +_OP(OPC_IO, OP_WRITE_CHAR, 1, 3, 0, SEXP_OPORT, 0, "write-char", (sexp)&cur_output_port, NULL), +_OP(OPC_IO, OP_NEWLINE, 0, 3, 0, SEXP_OPORT, 0, "newline", (sexp)&cur_output_port, NULL), +_OP(OPC_IO, OP_FLUSH_OUTPUT, 0, 3, 0, SEXP_OPORT, 0, "flush-output", (sexp)&cur_output_port, NULL), +_OP(OPC_IO, OP_READ, 0, 3, 0, SEXP_IPORT, 0, "read", (sexp)&cur_input_port, NULL), +_OP(OPC_IO, OP_READ_CHAR, 0, 3, 0, SEXP_IPORT, 0, "read-char", (sexp)&cur_input_port, NULL), _FN1(SEXP_PAIR, "length", sexp_length), _FN1(SEXP_PAIR, "reverse", sexp_reverse), _FN1(SEXP_PAIR, "list->vector", sexp_list_to_vector), diff --git a/eval.h b/eval.h index 8a8e88d0..71a20c30 100644 --- a/eval.h +++ b/eval.h @@ -107,6 +107,7 @@ enum opcode_names { OP_SUB, OP_MUL, OP_DIV, + OP_QUOT, OP_MOD, OP_NEG, OP_INV, diff --git a/sexp.c b/sexp.c index 1adc48ea..e6580236 100644 --- a/sexp.c +++ b/sexp.c @@ -93,7 +93,8 @@ sexp sexp_make_exception(sexp kind, sexp message, sexp irritants, sexp sexp_print_exception(sexp exn, sexp out) { sexp_write_string("error", out); - if (sexp_exception_line(exn) > sexp_make_integer(0)) { + 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); } diff --git a/sexp.h b/sexp.h index 54bd0ffb..230a019e 100644 --- a/sexp.h +++ b/sexp.h @@ -209,7 +209,8 @@ struct sexp_struct { #define sexp_env_flags(x) ((x)->value.env.flags) #define sexp_env_parent(x) ((x)->value.env.parent) #define sexp_env_bindings(x) ((x)->value.env.bindings) -#define sexp_env_global_p(x) (! sexp_env_parent(x)) +#define sexp_env_local_p(x) (sexp_env_parent(x)) +#define sexp_env_global_p(x) (! sexp_env_local_p(x)) #define sexp_macro_proc(x) ((x)->value.macro.proc) #define sexp_macro_env(x) ((x)->value.macro.env) @@ -228,7 +229,8 @@ struct sexp_struct { #define sexp_opcode_data(x) ((x)->value.opcode.data) #define sexp_opcode_proc(x) ((x)->value.opcode.proc) -#define sexp_opcode_variadic_p(x) (sexp_opcode_flags(x) & 1) +#define sexp_opcode_variadic_p(x) (sexp_opcode_flags(x) & 1) +#define sexp_opcode_opt_param_p(x) (sexp_opcode_flags(x) & 2) #if USE_STRING_STREAMS #if SEXP_BSD @@ -255,8 +257,8 @@ void sexp_printf(sexp port, sexp fmt, ...); #define sexp_fx_add(a, b) ((sexp)(((sexp_sint_t)a)+((sexp_sint_t)b)-SEXP_FIXNUM_TAG)) #define sexp_fx_sub(a, b) ((sexp)(((sexp_sint_t)a)-((sexp_sint_t)b)+SEXP_FIXNUM_TAG)) #define sexp_fx_mul(a, b) ((sexp)((((((sexp_sint_t)a)-SEXP_FIXNUM_TAG)*(((sexp_sint_t)b)>>SEXP_FIXNUM_BITS))+SEXP_FIXNUM_TAG))) -#define sexp_fx_div(a, b) ((sexp)(((((sexp_sint_t)a)>>SEXP_FIXNUM_BITS)/(((sexp_sint_t)b)>>SEXP_FIXNUM_BITS))<>SEXP_FIXNUM_BITS)%(((sexp_sint_t)b)>>SEXP_FIXNUM_BITS))< Date: Mon, 16 Mar 2009 18:37:33 +0900 Subject: [PATCH 043/154] various bugfixes --- debug.c | 6 +- defaults.h | 54 +++++++++ eval.c | 223 +++++++++++++++++++++--------------- eval.h | 6 - init.scm | 8 ++ sexp.h | 3 + tests/test03-closure.res | 6 + tests/test03-closure.scm | 16 +++ tests/test04-nested-let.res | 1 + tests/test04-nested-let.scm | 9 ++ tests/test05-letrec.res | 4 + tests/test05-letrec.scm | 27 +++++ tests/test06-mutation.res | 1 + tests/test06-mutation.scm | 10 ++ 14 files changed, 271 insertions(+), 103 deletions(-) create mode 100644 defaults.h create mode 100644 tests/test03-closure.res create mode 100644 tests/test03-closure.scm create mode 100644 tests/test04-nested-let.res create mode 100644 tests/test04-nested-let.scm create mode 100644 tests/test05-letrec.res create mode 100644 tests/test05-letrec.scm create mode 100644 tests/test06-mutation.res create mode 100644 tests/test06-mutation.scm diff --git a/debug.c b/debug.c index cdc88778..21021e5c 100644 --- a/debug.c +++ b/debug.c @@ -5,9 +5,9 @@ static const char* reverse_opcode_names[] = {"NOOP", "TAIL-CALL", "CALL", "APPLY1", "CALLCC", "RESUMECC", "ERROR", "FCALL0", "FCALL1", - "FCALL2", "FCALL3", /* "FCALL4", "FCALL5", "FCALL6", "FCALL7", */ "FCALLN", + "FCALL2", "FCALL3", "FCALLN", "JUMP-UNLESS", "JUMP", "RET", "DONE", "PARAMETER", - "STACK-REF", "STACK-SET", "GLOBAL-REF", "GLOBAL-SET", "CLOSURE-REF", + "STACK-REF", "STACK-SET", "CLOSURE-REF", "VECTOR-REF", "VECTOR-SET", "STRING-REF", "STRING-SET", "MAKE-PROCEDURE", "MAKE-VECTOR", "PUSH", "DROP", "PAIRP", "NULLP", "VECTORP", "INTEGERP", "SYMBOLP", "STRINGP", "CHARP", "EOFP", "PROCEDUREP", "IPORTP", @@ -34,8 +34,6 @@ void disasm (sexp bc) { fprintf(stderr, "%ld", (long) ((sexp*)ip)[0]); ip += sizeof(sexp); break; - case OP_GLOBAL_REF: - case OP_GLOBAL_SET: case OP_TAIL_CALL: case OP_CALL: case OP_PUSH: diff --git a/defaults.h b/defaults.h new file mode 100644 index 00000000..f48a538d --- /dev/null +++ b/defaults.h @@ -0,0 +1,54 @@ +/* defaults.h -- defaults for unspecified configs */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#if HAVE_ERR_H +#include +#else +/* requires msg be a string literal, and at least one argument */ +#define errx(code, msg, ...) (fprintf(stderr,msg"\n",__VA_ARGS__), exit(code)) +#endif + +#if defined(__APPLE__) || defined(__FreeBSD__) || defined(__NetBSD__) || defined(__DragonFly__) || defined(__OpenBSD__) +#define SEXP_BSD 1 +#else +#define SEXP_BSD 0 +#endif + +#ifndef USE_BOEHM +#define USE_BOEHM 1 +#endif + +#ifndef USE_FLONUMS +#define USE_FLONUMS 1 +#endif + +#ifndef USE_HUFF_SYMS +#define USE_HUFF_SYMS 1 +#endif + +#ifndef USE_DEBUG +#define USE_DEBUG 1 +#endif + +#ifndef USE_STRING_STREAMS +#define USE_STRING_STREAMS 1 +#endif + +#ifndef USE_FAST_LET +#define USE_FAST_LET 1 +#endif + +#if USE_BOEHM +#include "gc/include/gc.h" +#define SEXP_ALLOC GC_malloc +#define SEXP_ALLOC_ATOMIC GC_malloc_atomic +#define SEXP_REALLOC GC_realloc +#define SEXP_FREE GC_free +#else +#define SEXP_ALLOC malloc +#define SEXP_ALLOC_ATOMIC SEXP_ALLOC +#define SEXP_REALLOC realloc +#define SEXP_FREE free +#endif + diff --git a/eval.c b/eval.c index 97f2a5b2..9279dbf2 100644 --- a/eval.c +++ b/eval.c @@ -37,6 +37,17 @@ static sexp env_cell(sexp e, sexp key) { return NULL; } +static sexp env_cell_create(sexp e, sexp key) { + sexp cell = env_cell(e, key); + if (! cell) { + cell = sexp_cons(key, SEXP_UNDEF); + while (sexp_env_parent(e)) + e = sexp_env_parent(e); + sexp_env_bindings(e) = sexp_cons(cell, sexp_env_bindings(e)); + } + return cell; +} + static int env_global_p (sexp e, sexp id) { while (sexp_env_parent(e)) { if (sexp_assq(id, sexp_env_bindings(e)) != SEXP_FALSE) @@ -48,16 +59,11 @@ static int env_global_p (sexp e, sexp id) { } static void env_define(sexp e, sexp key, sexp value) { - sexp cell = env_cell(e, key); - if (cell) { - sexp_cdr(cell) = value; - } else { - sexp_env_bindings(e) - = sexp_cons(sexp_cons(key, value), sexp_env_bindings(e)); - } + sexp cell = env_cell_create(e, key); + sexp_cdr(cell) = value; } -static sexp extend_env_closure (sexp e, sexp fv, int offset) { +static sexp extend_env (sexp e, sexp fv, int offset) { int i; sexp e2 = (sexp) SEXP_ALLOC(sexp_sizeof(env)); e2->tag = SEXP_ENV; @@ -127,15 +133,17 @@ static void emit_word(sexp *bc, sexp_uint_t *i, sexp_uint_t val) { *i += sizeof(sexp_uint_t); } -#define emit_push(bc,i,obj) (emit(bc,i,OP_PUSH), \ - emit_word(bc,i,(sexp_uint_t)obj)) +static void emit_push(sexp *bc, sexp_uint_t *i, sexp obj) { + emit(bc, i, OP_PUSH); + emit_word(bc, i, (sexp_uint_t)obj); +} -static sexp sexp_make_procedure(char flags, unsigned short num_args, +static sexp sexp_make_procedure(sexp flags, sexp num_args, sexp bc, sexp vars) { sexp proc = (sexp) SEXP_ALLOC(sexp_sizeof(procedure)); proc->tag = SEXP_PROCEDURE; - sexp_procedure_flags(proc) = flags; - sexp_procedure_num_args(proc) = num_args; + sexp_procedure_flags(proc) = (char) (sexp_uint_t) flags; + sexp_procedure_num_args(proc) = (unsigned short) (sexp_uint_t) num_args; sexp_procedure_code(proc) = bc; sexp_procedure_vars(proc) = vars; return proc; @@ -174,7 +182,7 @@ sexp sexp_expand_macro (sexp mac, sexp form, sexp e) { emit_word(&bc, &i, (sexp_uint_t) sexp_make_integer(3)); emit(&bc, &i, OP_DONE); res = vm(bc, e, stack, 0); -/* sexp_write(res, cur_error_port); */ + sexp_write(res, cur_error_port); /* fprintf(stderr, "\n"); */ SEXP_FREE(bc); SEXP_FREE(stack); @@ -184,7 +192,7 @@ sexp sexp_expand_macro (sexp mac, sexp form, sexp e) { sexp analyze(sexp obj, sexp *bc, sexp_uint_t *i, sexp e, sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp) { int tmp1, tmp2; - sexp o1, o2, e2, exn; + sexp o1, o2, e2, cell, exn; loop: if (sexp_pairp(obj)) { @@ -219,15 +227,18 @@ sexp analyze(sexp obj, sexp *bc, sexp_uint_t *i, sexp e, } if (sexp_exceptionp(exn)) return exn; if (sexp_env_global_p(e)) { - emit(bc, i, OP_GLOBAL_SET); - emit_word(bc, i, (sexp_uint_t) o2); - emit_push(bc, i, SEXP_UNDEF); + cell = env_cell_create(e, o2); + emit_push(bc, i, cell); + emit(bc, i, OP_SET_CDR); } else { - o1 = env_cell(e, o2); - return sexp_compile_error("define in bad position", - sexp_list1(obj)); - emit(bc, i, OP_STACK_SET); - emit_word(bc, i, sexp_unbox_integer(sexp_cdr(o1))); + cell = env_cell(e, o2); + if (! cell || ! sexp_integerp(sexp_cdr(cell))) { + return sexp_compile_error("define in bad position", + sexp_list1(obj)); + } else { + emit(bc, i, OP_STACK_SET); + emit_word(bc, i, (*d)+1-sexp_unbox_integer(sexp_cdr(cell))); + } } (*d)++; break; @@ -237,10 +248,11 @@ sexp analyze(sexp obj, sexp *bc, sexp_uint_t *i, sexp e, if (sexp_list_index(sv, sexp_cadr(obj)) >= 0) { analyze_var_ref(sexp_cadr(obj), bc, i, e, params, fv, SEXP_NULL, d); emit(bc, i, OP_SET_CAR); + (*d)--; } else { - emit(bc, i, OP_GLOBAL_SET); - emit_word(bc, i, (sexp_uint_t) sexp_cadr(obj)); - emit_push(bc, i, SEXP_UNDEF); + cell = env_cell_create(e, sexp_cadr(obj)); + emit_push(bc, i, cell); + emit(bc, i, OP_SET_CDR); } break; case CORE_BEGIN: @@ -301,7 +313,7 @@ sexp analyze(sexp obj, sexp *bc, sexp_uint_t *i, sexp e, if (sexp_exceptionp(exn)) return exn; } /* analyze the body in a new local env */ - e2 = extend_env_closure(e, sexp_cadar(obj), (*d)+(tmp1-1)); + e2 = extend_env(e, sexp_cadar(obj), (*d)+(tmp1-1)); params = sexp_append(sexp_cadar(obj), params); exn = analyze_sequence(sexp_cddar(obj), bc, i, e, params, fv, sv, d, tailp); @@ -335,7 +347,8 @@ sexp analyze_sequence (sexp ls, sexp *bc, sexp_uint_t *i, sexp e, for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) { if (sexp_pairp(sexp_cdr(ls))) { exn = analyze(sexp_car(ls), bc, i, e, params, fv, sv, d, 0); - if (sexp_exceptionp(exn)) return exn; + if (sexp_exceptionp(exn)) + return exn; emit(bc, i, OP_DROP); (*d)--; } else { @@ -358,8 +371,6 @@ sexp analyze_opcode (sexp op, sexp obj, sexp *bc, sexp_uint_t *i, sexp e, if (! sexp_opcode_variadic_p(op)) return sexp_compile_error("too many arguments", sexp_list1(obj)); } else if (sexp_opcode_variadic_p(op) && sexp_opcode_data(op)) { - fprintf(stderr, "compiling parameter: %p for op %s\n", - sexp_opcode_data(op), sexp_opcode_name(op)); emit(bc, i, OP_PARAMETER); emit_word(bc, i, (sexp_uint_t) sexp_opcode_data(op)); if (! sexp_opcode_opt_param_p(op)) { @@ -382,16 +393,27 @@ sexp analyze_opcode (sexp op, sexp obj, sexp *bc, sexp_uint_t *i, sexp e, } else { if (sexp_opcode_class(op) == OPC_FOREIGN) emit_push(bc, i, sexp_opcode_data(op)); + else if ((len > 2) && sexp_opcode_class(op) == OPC_ARITHMETIC_CMP) { + emit(bc, i, OP_STACK_REF); + emit_word(bc, i, 2); + } emit(bc, i, sexp_opcode_inverse(op) ? sexp_opcode_inverse(op) : sexp_opcode_code(op)); } - /* emit optional multiple copies of operator */ - if ((len > 1) - && (sexp_opcode_class(op) == OPC_ARITHMETIC - || sexp_opcode_class(op) == OPC_ARITHMETIC_INV)) - for (j=len-2; j>0; j--) - emit(bc, i, sexp_opcode_code(op)); + /* emit optional folding of operator */ + if (len > 2) { + if (sexp_opcode_class(op) == OPC_ARITHMETIC + || sexp_opcode_class(op) == OPC_ARITHMETIC_INV) { + for (j=len-2; j>0; j--) + emit(bc, i, sexp_opcode_code(op)); + } else if (sexp_opcode_class(op) == OPC_ARITHMETIC_CMP) { + for (j=len-2; j>0; j--) { + /* emit(bc, i, OP_JUMP_UNLESS); */ + emit(bc, i, sexp_opcode_code(op)); + } + } + } if (sexp_opcode_class(op) == OPC_PARAMETER) emit_word(bc, i, (sexp_uint_t) sexp_opcode_data(op)); @@ -404,17 +426,18 @@ sexp analyze_opcode (sexp op, sexp obj, sexp *bc, sexp_uint_t *i, sexp e, void analyze_var_ref (sexp obj, sexp *bc, sexp_uint_t *i, sexp e, sexp params, sexp fv, sexp sv, sexp_uint_t *d) { int tmp; - sexp o1; + sexp cell; if ((tmp = sexp_list_index(params, obj)) >= 0) { - o1 = env_cell(e, obj); + cell = env_cell(e, obj); emit(bc, i, OP_STACK_REF); - emit_word(bc, i, *d - sexp_unbox_integer(sexp_cdr(o1))); + emit_word(bc, i, *d - sexp_unbox_integer(sexp_cdr(cell))); } else if ((tmp = sexp_list_index(fv, obj)) >= 0) { emit(bc, i, OP_CLOSURE_REF); emit_word(bc, i, (sexp_uint_t) sexp_make_integer(tmp)); } else { - emit(bc, i, OP_GLOBAL_REF); - emit_word(bc, i, (sexp_uint_t) obj); + cell = env_cell_create(e, obj); + emit_push(bc, i, cell); + emit(bc, i, OP_CDR); } (*d)++; if (sexp_list_index(sv, obj) >= 0) { @@ -480,16 +503,18 @@ sexp free_vars (sexp e, sexp formals, sexp obj, sexp fv) { } sexp set_vars (sexp e, sexp formals, sexp obj, sexp sv) { - sexp tmp; + sexp cell; + int code; if (sexp_nullp(formals)) return sv; if (sexp_pairp(obj)) { if (sexp_symbolp(sexp_car(obj))) { - if ((tmp = env_cell(e, sexp_car(obj))) && sexp_corep(sexp_cdr(tmp))) { - if (sexp_core_code(sexp_cdr(tmp)) == CORE_LAMBDA) { + if ((cell = env_cell(e, sexp_car(obj))) && sexp_corep(sexp_cdr(cell))) { + code = sexp_core_code(sexp_cdr(cell)); + if (code == CORE_LAMBDA) { formals = sexp_lset_diff(formals, sexp_cadr(obj)); return set_vars(e, formals, sexp_caddr(obj), sv); - } else if (sexp_core_code(sexp_cdr(tmp)) == CORE_SET + } else if ((code == CORE_SET || code == CORE_DEFINE) && (sexp_list_index(formals, sexp_cadr(obj)) >= 0) && ! (sexp_list_index(sv, sexp_cadr(obj)) >= 0)) { sv = sexp_cons(sexp_cadr(obj), sv); @@ -513,29 +538,41 @@ sexp analyze_lambda (sexp name, sexp formals, sexp body, int k; flat_formals = sexp_flatten_dot(formals); fv2 = free_vars(e, flat_formals, body, SEXP_NULL); - e2 = extend_env_closure(e, flat_formals, -4); + e2 = extend_env(e, flat_formals, -4); /* compile the body with respect to the new params */ obj = compile(flat_formals, body, e2, fv2, sv, 0); if (sexp_exceptionp(obj)) return obj; - /* push the closed vars */ - emit_push(bc, i, SEXP_UNDEF); - emit_push(bc, i, sexp_length(fv2)); - emit(bc, i, OP_MAKE_VECTOR); - (*d)++; - for (ls=fv2, k=0; sexp_pairp(ls); ls=sexp_cdr(ls), k++) { - analyze_var_ref(sexp_car(ls), bc, i, e, params, fv, SEXP_NULL, d); - emit_push(bc, i, sexp_make_integer(k)); - emit(bc, i, OP_STACK_REF); - emit_word(bc, i, 3); - emit(bc, i, OP_VECTOR_SET); - emit(bc, i, OP_DROP); - (*d)--; + if (sexp_nullp(fv2)) { + /* no variables to close over, fixed procedure */ + emit_push(bc, i, + sexp_make_procedure(sexp_make_integer((sexp_listp(formals) + ? 0 : 1)), + sexp_length(formals), + obj, + sexp_make_vector(sexp_make_integer(0), + SEXP_UNDEF))); + (*d)++; + } else { + /* push the closed vars */ + emit_push(bc, i, SEXP_UNDEF); + emit_push(bc, i, sexp_length(fv2)); + emit(bc, i, OP_MAKE_VECTOR); + (*d)++; + for (ls=fv2, k=0; sexp_pairp(ls); ls=sexp_cdr(ls), k++) { + analyze_var_ref(sexp_car(ls), bc, i, e, params, fv, SEXP_NULL, d); + emit_push(bc, i, sexp_make_integer(k)); + emit(bc, i, OP_STACK_REF); + emit_word(bc, i, 3); + emit(bc, i, OP_VECTOR_SET); + emit(bc, i, OP_DROP); + (*d)--; + } + /* push the additional procedure info and make the closure */ + emit_push(bc, i, obj); + emit_push(bc, i, sexp_length(formals)); + emit_push(bc, i, sexp_make_integer(sexp_listp(formals) ? 0 : 1)); + emit(bc, i, OP_MAKE_PROCEDURE); } - /* push the additional procedure info and make the closure */ - emit_push(bc, i, obj); - emit_push(bc, i, sexp_length(formals)); - emit_push(bc, i, sexp_make_integer(sexp_listp(formals) ? 0 : 1)); - emit(bc, i, OP_MAKE_PROCEDURE); return SEXP_TRUE; } @@ -556,7 +593,7 @@ sexp make_opcode_procedure(sexp op, sexp_uint_t i, sexp e) { return sexp_opcode_proc(op); bc = (sexp) SEXP_ALLOC(sexp_sizeof(bytecode)+INIT_BCODE_SIZE); params = make_param_list(i); - e = extend_env_closure(e, params, -4); + e = extend_env(e, params, -4); bc->tag = SEXP_BYTECODE; sexp_bytecode_length(bc) = INIT_BCODE_SIZE; analyze_opcode(op, sexp_cons(op, params), &bc, &pos, e, params, @@ -564,27 +601,28 @@ sexp make_opcode_procedure(sexp op, sexp_uint_t i, sexp e) { emit(&bc, &pos, OP_RET); shrink_bcode(&bc, pos); /* disasm(bc); */ - res = sexp_make_procedure(0, (int) sexp_make_integer(i), bc, SEXP_UNDEF); + res = sexp_make_procedure(sexp_make_integer(0), sexp_make_integer(i), bc, SEXP_UNDEF); if (i == sexp_opcode_num_args(op)) sexp_opcode_proc(op) = res; return res; } sexp compile(sexp params, sexp obj, sexp e, sexp fv, sexp sv, int done_p) { - sexp_uint_t i=0, j=0, d=0, define_ok=1, core; + sexp_uint_t i=0, d=0, define_ok=1, core; + sexp_sint_t j=0; sexp bc = (sexp) SEXP_ALLOC(sexp_sizeof(bytecode)+INIT_BCODE_SIZE); sexp sv2 = set_vars(e, params, obj, SEXP_NULL), internals=SEXP_NULL, ls; bc->tag = SEXP_BYTECODE; sexp_bytecode_length(bc) = INIT_BCODE_SIZE; /* box mutable vars */ for (ls=params; sexp_pairp(ls); ls=sexp_cdr(ls)) { - if ((j = sexp_list_index(sv2, sexp_car(ls)) >= 0)) { + if ((j = sexp_list_index(sv2, sexp_car(ls))) >= 0) { emit_push(&bc, &i, SEXP_NULL); emit(&bc, &i, OP_STACK_REF); - emit_word(&bc, &i, j+4); + emit_word(&bc, &i, j+5); emit(&bc, &i, OP_CONS); emit(&bc, &i, OP_STACK_SET); - emit_word(&bc, &i, j+4); + emit_word(&bc, &i, j+5); emit(&bc, &i, OP_DROP); } } @@ -599,8 +637,9 @@ sexp compile(sexp params, sexp obj, sexp e, sexp fv, sexp sv, int done_p) { sexp_append(sexp_cdar(obj), sexp_cdr(obj))); } else { if (core == CORE_DEFINE) { - return sexp_compile_error("definition in non-definition context", - sexp_list1(obj)); + if (! define_ok) + return sexp_compile_error("definition in non-definition context", + sexp_list1(obj)); internals = sexp_cons(sexp_pairp(sexp_cadar(obj)) ? sexp_car(sexp_cadar(obj)) : sexp_cadar(obj), internals); @@ -613,10 +652,11 @@ sexp compile(sexp params, sexp obj, sexp e, sexp fv, sexp sv, int done_p) { obj = sexp_reverse(ls); j = sexp_unbox_integer(sexp_length(internals)); if (sexp_pairp(internals)) { - e = extend_env_closure(e, internals, 2); + e = extend_env(e, internals, d+j); + /* XXXX params extended, need to recompute set-vars */ params = sexp_append(internals, params); for (ls=internals; sexp_pairp(ls); ls=sexp_cdr(ls)) - emit_push(&bc, &i, (sexp_uint_t) SEXP_UNDEF); + emit_push(&bc, &i, SEXP_UNDEF); d+=j; } } @@ -631,8 +671,8 @@ sexp compile(sexp params, sexp obj, sexp e, sexp fv, sexp sv, int done_p) { } emit(&bc, &i, done_p ? OP_DONE : OP_RET); shrink_bcode(&bc, i); - /* print_bytecode(bc); */ - /* disasm(bc); */ + print_bytecode(bc); + disasm(bc); return bc; } @@ -677,22 +717,16 @@ sexp vm(sexp bc, sexp e, sexp* stack, sexp_sint_t top) { case OP_NOOP: fprintf(stderr, "noop\n"); break; - case OP_GLOBAL_REF: - tmp1 = env_cell(e, ((sexp*)ip)[0]); - if (! tmp1) sexp_raise("undefined-variable", sexp_list1(tmp1)); - stack[top++]=sexp_cdr(tmp1); - ip += sizeof(sexp); - break; - case OP_GLOBAL_SET: - env_define(e, ((sexp*)ip)[0], _POP()); - ip += sizeof(sexp); - break; case OP_STACK_REF: +/* fprintf(stderr, "STACK-REF[%ld - %ld = %ld]\n", top, */ +/* (sexp_sint_t) ((sexp*)ip)[0], top - (sexp_sint_t) ((sexp*)ip)[0]); */ stack[top] = stack[top - (sexp_sint_t) ((sexp*)ip)[0]]; ip += sizeof(sexp); top++; break; case OP_STACK_SET: +/* fprintf(stderr, "STACK-SET[%ld - %ld = %ld]\n", top, */ +/* (sexp_sint_t) ((sexp*)ip)[0], top - (sexp_sint_t) ((sexp*)ip)[0]); */ stack[top - (sexp_sint_t) ((sexp*)ip)[0]] = _ARG1; _ARG1 = SEXP_UNDEF; ip += sizeof(sexp); @@ -720,7 +754,7 @@ sexp vm(sexp bc, sexp e, sexp* stack, sexp_sint_t top) { top-=2; break; case OP_MAKE_PROCEDURE: - _ARG4 = sexp_make_procedure((int) _ARG1, (int) _ARG2, _ARG3, _ARG4); + _ARG4 = sexp_make_procedure(_ARG1, _ARG2, _ARG3, _ARG4); top-=3; break; case OP_MAKE_VECTOR: @@ -962,7 +996,7 @@ sexp vm(sexp bc, sexp e, sexp* stack, sexp_sint_t top) { stack[top+1] = sexp_make_integer(ip); stack[top+2] = cp; _ARG1 - = sexp_make_procedure(0, (int) sexp_make_integer(1), + = sexp_make_procedure(sexp_make_integer(0), sexp_make_integer(1), continuation_resumer, sexp_vector(1, sexp_save_stack(stack, top+3))); top++; @@ -1138,9 +1172,9 @@ _OP(OPC_ARITHMETIC, OP_QUOT, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, 0, "quotient", _OP(OPC_ARITHMETIC, OP_MOD, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, 0, "modulo", NULL, NULL), _OP(OPC_ARITHMETIC_CMP, OP_LT, 0, 1, SEXP_FIXNUM, 0, 0, "<", NULL, NULL), _OP(OPC_ARITHMETIC_CMP, OP_LE, 0, 1, SEXP_FIXNUM, 0, 0, "<=", NULL, NULL), -_OP(OPC_ARITHMETIC_CMP, OP_GT, 0, 1, SEXP_FIXNUM, 0, 0, ">", NULL, NULL), -_OP(OPC_ARITHMETIC_CMP, OP_GE, 0, 1, SEXP_FIXNUM, 0, 0, ">=", NULL, NULL), -_OP(OPC_ARITHMETIC_CMP, OP_EQN, 0, 1, SEXP_FIXNUM, 0, 0, "=", NULL, NULL), +_OP(OPC_ARITHMETIC_CMP, OP_GT, 0, 1, SEXP_FIXNUM, 0, OP_LE, ">", NULL, NULL), +_OP(OPC_ARITHMETIC_CMP, OP_GE, 0, 1, SEXP_FIXNUM, 0, OP_LT, ">=", NULL, NULL), +_OP(OPC_ARITHMETIC_CMP, OP_EQ, 0, 1, SEXP_FIXNUM, 0, 0, "=", NULL, NULL), _OP(OPC_PREDICATE, OP_EQ, 2, 0, 0, 0, 0, "eq?", NULL, NULL), _OP(OPC_CONSTRUCTOR, OP_CONS, 2, 0, 0, 0, 0, "cons", NULL, NULL), _OP(OPC_CONSTRUCTOR, OP_MAKE_VECTOR, 2, 0, SEXP_FIXNUM, 0, 0, "make-vector", NULL, NULL), @@ -1262,9 +1296,12 @@ int main (int argc, char **argv) { bc->tag = SEXP_BYTECODE; sexp_bytecode_length(bc) = 16; i = 0; - emit_push(&bc, &i, (sexp_uint_t) SEXP_UNDEF); + emit_push(&bc, &i, SEXP_UNDEF); emit(&bc, &i, OP_DONE); - err_handler = sexp_make_procedure(0, 0, bc, sexp_make_vector(0, SEXP_UNDEF)); + err_handler = sexp_make_procedure(sexp_make_integer(0), + sexp_make_integer(0), + bc, + sexp_make_vector(0, SEXP_UNDEF)); err_handler_sym = sexp_intern("*error-handler*"); env_define(e, err_handler_sym, err_handler); exception_handler_cell = env_cell(e, err_handler_sym); diff --git a/eval.h b/eval.h index 71a20c30..d20794d5 100644 --- a/eval.h +++ b/eval.h @@ -64,10 +64,6 @@ enum opcode_names { OP_FCALL1, OP_FCALL2, OP_FCALL3, -/* OP_FCALL4, */ -/* OP_FCALL5, */ -/* OP_FCALL6, */ -/* OP_FCALL7, */ OP_FCALLN, OP_JUMP_UNLESS, OP_JUMP, @@ -76,8 +72,6 @@ enum opcode_names { OP_PARAMETER, OP_STACK_REF, OP_STACK_SET, - OP_GLOBAL_REF, - OP_GLOBAL_SET, OP_CLOSURE_REF, OP_VECTOR_REF, OP_VECTOR_SET, diff --git a/init.scm b/init.scm index 46afc7e2..b8877e78 100644 --- a/init.scm +++ b/init.scm @@ -76,6 +76,14 @@ ;; syntax +(define-syntax letrec + (lambda (expr use-env mac-env) + (list + (cons 'lambda + (cons '() + (append (map (lambda (x) (cons 'define x)) (cadr expr)) + (cddr expr))))))) + (define-syntax let (lambda (expr use-env mac-env) (cons (cons 'lambda (cons (map car (cadr expr)) (cddr expr))) diff --git a/sexp.h b/sexp.h index 230a019e..ba1afd88 100644 --- a/sexp.h +++ b/sexp.h @@ -108,6 +108,9 @@ struct sexp_struct { struct { sexp proc, env; } macro; + struct { + sexp env, free_vars, expr; + } sc; struct { unsigned char op_class, code, num_args, flags, arg1_type, arg2_type, inverse; diff --git a/tests/test03-closure.res b/tests/test03-closure.res new file mode 100644 index 00000000..4d764d20 --- /dev/null +++ b/tests/test03-closure.res @@ -0,0 +1,6 @@ +1 +2 +101 +102 +3 +103 diff --git a/tests/test03-closure.scm b/tests/test03-closure.scm new file mode 100644 index 00000000..6ed987fe --- /dev/null +++ b/tests/test03-closure.scm @@ -0,0 +1,16 @@ + +(define (make-counter n) + (lambda () + (set! n (+ n 1)) + n)) + +(define f (make-counter 0)) +(define g (make-counter 100)) + +(write (f)) (newline) +(write (f)) (newline) +(write (g)) (newline) +(write (g)) (newline) +(write (f)) (newline) +(write (g)) (newline) + diff --git a/tests/test04-nested-let.res b/tests/test04-nested-let.res new file mode 100644 index 00000000..c97c8394 --- /dev/null +++ b/tests/test04-nested-let.res @@ -0,0 +1 @@ +11357 diff --git a/tests/test04-nested-let.scm b/tests/test04-nested-let.scm new file mode 100644 index 00000000..584bc6e5 --- /dev/null +++ b/tests/test04-nested-let.scm @@ -0,0 +1,9 @@ + +(let ((a 3) + (b 5)) + (let ((c (- a 2)) + (d (+ b 2)) + (e 10000)) + (write (+ e (* c 1000) (* a 100) (* b 10) d)) + (newline))) + diff --git a/tests/test05-letrec.res b/tests/test05-letrec.res new file mode 100644 index 00000000..83d9c566 --- /dev/null +++ b/tests/test05-letrec.res @@ -0,0 +1,4 @@ +7 +#t +#f +#f diff --git a/tests/test05-letrec.scm b/tests/test05-letrec.scm new file mode 100644 index 00000000..62b1e078 --- /dev/null +++ b/tests/test05-letrec.scm @@ -0,0 +1,27 @@ + +(letrec ((add (lambda (a b) (+ a b)))) + (write (add 3 4)) + (newline)) + +;; (letrec ((even? (lambda (n) (if (zero? n) #t (odd? (- n 1))))) +;; (odd? (lambda (n) (if (zero? n) #f (even? (- n 1)))))) +;; (write (even? 1000)) +;; (newline) +;; (write (even? 1001)) +;; (newline) +;; (write (odd? 1000)) +;; (newline) +;; ) + +((lambda (even? odd?) + (set! even? (lambda (n) (if (zero? n) #t (odd? (- n 1))))) + (set! odd? (lambda (n) (if (zero? n) #f (even? (- n 1))))) + (write (even? 1000)) + (newline) + (write (even? 1001)) + (newline) + (write (odd? 1000)) + (newline) + ) + 'even 'odd) + diff --git a/tests/test06-mutation.res b/tests/test06-mutation.res new file mode 100644 index 00000000..c97c8394 --- /dev/null +++ b/tests/test06-mutation.res @@ -0,0 +1 @@ +11357 diff --git a/tests/test06-mutation.scm b/tests/test06-mutation.scm new file mode 100644 index 00000000..7be0f055 --- /dev/null +++ b/tests/test06-mutation.scm @@ -0,0 +1,10 @@ + +(let ((a 3) + (b 5)) + (let ((c (- a 2)) + (d (+ b 2)) + (e #f)) + (set! e 10000) + (write (+ e (* c 1000) (* a 100) (* b 10) d)) + (newline))) + From 9af5279e6f628dd0ba1cd7f6ca94f86c5845b5c8 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 16 Mar 2009 19:26:06 +0900 Subject: [PATCH 044/154] fixing stack offsets for mutated variables --- eval.c | 31 ++++++++++++++++--------------- sexp.c | 20 +++++++++++++++----- tests/test05-letrec.scm | 6 +++--- tests/test06-mutation.scm | 1 - 4 files changed, 34 insertions(+), 24 deletions(-) diff --git a/eval.c b/eval.c index 9279dbf2..9da6bb0e 100644 --- a/eval.c +++ b/eval.c @@ -608,15 +608,14 @@ sexp make_opcode_procedure(sexp op, sexp_uint_t i, sexp e) { } sexp compile(sexp params, sexp obj, sexp e, sexp fv, sexp sv, int done_p) { - sexp_uint_t i=0, d=0, define_ok=1, core; - sexp_sint_t j=0; + sexp_uint_t i=0, j=0, d=0, define_ok=1, core; sexp bc = (sexp) SEXP_ALLOC(sexp_sizeof(bytecode)+INIT_BCODE_SIZE); sexp sv2 = set_vars(e, params, obj, SEXP_NULL), internals=SEXP_NULL, ls; bc->tag = SEXP_BYTECODE; sexp_bytecode_length(bc) = INIT_BCODE_SIZE; /* box mutable vars */ - for (ls=params; sexp_pairp(ls); ls=sexp_cdr(ls)) { - if ((j = sexp_list_index(sv2, sexp_car(ls))) >= 0) { + for (ls=params, j=0; sexp_pairp(ls); ls=sexp_cdr(ls), j++) { + if (sexp_list_index(sv2, sexp_car(ls)) >= 0) { emit_push(&bc, &i, SEXP_NULL); emit(&bc, &i, OP_STACK_REF); emit_word(&bc, &i, j+5); @@ -795,19 +794,21 @@ sexp vm(sexp bc, sexp e, sexp* stack, sexp_sint_t top) { case OP_EOFP: _ARG1 = sexp_make_boolean(_ARG1 == SEXP_EOF); break; case OP_CAR: - if (! sexp_pairp(_ARG1)) sexp_raise("not a pair", sexp_list1(_ARG1)); + if (! sexp_pairp(_ARG1)) sexp_raise("car: not a pair", sexp_list1(_ARG1)); _ARG1 = sexp_car(_ARG1); break; case OP_CDR: - if (! sexp_pairp(_ARG1)) sexp_raise("not a pair", sexp_list1(_ARG1)); + if (! sexp_pairp(_ARG1)) sexp_raise("cdr: not a pair", sexp_list1(_ARG1)); _ARG1 = sexp_cdr(_ARG1); break; case OP_SET_CAR: - if (! sexp_pairp(_ARG1)) sexp_raise("not a pair", sexp_list1(_ARG1)); + if (! sexp_pairp(_ARG1)) + sexp_raise("set-car!: not a pair", sexp_list1(_ARG1)); sexp_car(_ARG1) = _ARG2; _ARG2 = SEXP_UNDEF; top--; break; case OP_SET_CDR: - if (! sexp_pairp(_ARG1)) sexp_raise("not a pair", sexp_list1(_ARG1)); + if (! sexp_pairp(_ARG1)) + sexp_raise("set-cdr!: not a pair", sexp_list1(_ARG1)); sexp_cdr(_ARG1) = _ARG2; _ARG2 = SEXP_UNDEF; top--; @@ -827,7 +828,7 @@ sexp vm(sexp bc, sexp e, sexp* stack, sexp_sint_t top) { else if (sexp_integerp(_ARG1) && sexp_flonump(_ARG2)) _ARG2 = sexp_fp_add(sexp_integer_to_flonum(_ARG1), _ARG2); #endif - else sexp_raise("not a number", sexp_list2(_ARG1, _ARG2)); + else sexp_raise("+: not a number", sexp_list2(_ARG1, _ARG2)); top--; break; case OP_SUB: @@ -841,7 +842,7 @@ sexp vm(sexp bc, sexp e, sexp* stack, sexp_sint_t top) { else if (sexp_integerp(_ARG1) && sexp_flonump(_ARG2)) _ARG2 = sexp_fp_sub(sexp_integer_to_flonum(_ARG1), _ARG2); #endif - else sexp_raise("not a number", sexp_list2(_ARG1, _ARG2)); + else sexp_raise("-: not a number", sexp_list2(_ARG1, _ARG2)); top--; break; case OP_MUL: @@ -855,7 +856,7 @@ sexp vm(sexp bc, sexp e, sexp* stack, sexp_sint_t top) { else if (sexp_integerp(_ARG1) && sexp_flonump(_ARG2)) _ARG2 = sexp_fp_mul(sexp_integer_to_flonum(_ARG1), _ARG2); #endif - else sexp_raise("not a number", sexp_list2(_ARG1, _ARG2)); + else sexp_raise("*: not a number", sexp_list2(_ARG1, _ARG2)); top--; break; case OP_DIV: @@ -870,7 +871,7 @@ sexp vm(sexp bc, sexp e, sexp* stack, sexp_sint_t top) { else if (sexp_integerp(_ARG1) && sexp_flonump(_ARG2)) _ARG2 = sexp_fp_div(sexp_integer_to_flonum(_ARG1), _ARG2); #endif - else sexp_raise("not a number", sexp_list2(_ARG1, _ARG2)); + else sexp_raise("/: not a number", sexp_list2(_ARG1, _ARG2)); top--; break; case OP_QUOT: @@ -878,14 +879,14 @@ sexp vm(sexp bc, sexp e, sexp* stack, sexp_sint_t top) { _ARG2 = sexp_fx_div(_ARG1, _ARG2); top--; } - else sexp_raise("not a number", sexp_list2(_ARG1, _ARG2)); + else sexp_raise("quotient: not a number", sexp_list2(_ARG1, _ARG2)); break; case OP_MOD: if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) { _ARG2 = sexp_fx_mod(_ARG1, _ARG2); top--; } - else sexp_raise("not a number", sexp_list2(_ARG1, _ARG2)); + else sexp_raise("modulo: not a number", sexp_list2(_ARG1, _ARG2)); break; case OP_NEG: if (sexp_integerp(_ARG1)) @@ -894,7 +895,7 @@ sexp vm(sexp bc, sexp e, sexp* stack, sexp_sint_t top) { else if (sexp_flonump(_ARG1)) _ARG1 = sexp_make_flonum(-sexp_flonum_value(_ARG1)); #endif - else sexp_raise("not a number", sexp_list2(_ARG1, _ARG2)); + else sexp_raise("-: not a number", sexp_list1(_ARG1)); break; case OP_LT: _ARG2 = sexp_make_boolean(_ARG1 < _ARG2); diff --git a/sexp.c b/sexp.c index e6580236..ba515524 100644 --- a/sexp.c +++ b/sexp.c @@ -92,7 +92,8 @@ sexp sexp_make_exception(sexp kind, sexp message, sexp irritants, } sexp sexp_print_exception(sexp exn, sexp out) { - sexp_write_string("error", 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); @@ -104,11 +105,20 @@ sexp sexp_print_exception(sexp exn, sexp out) { } sexp_write_string(": ", out); sexp_write_string(sexp_string_data(sexp_exception_message(exn)), out); - sexp_write_string("\n", out); if (sexp_pairp(sexp_exception_irritants(exn))) { - sexp_write_string(" irritants: ", out); - sexp_write(sexp_exception_irritants(exn), out); - sexp_write_string("\n", out); + 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; } diff --git a/tests/test05-letrec.scm b/tests/test05-letrec.scm index 62b1e078..fd3a9fa2 100644 --- a/tests/test05-letrec.scm +++ b/tests/test05-letrec.scm @@ -16,11 +16,11 @@ ((lambda (even? odd?) (set! even? (lambda (n) (if (zero? n) #t (odd? (- n 1))))) (set! odd? (lambda (n) (if (zero? n) #f (even? (- n 1))))) - (write (even? 1000)) + (write (even? 100)) (newline) - (write (even? 1001)) + (write (even? 101)) (newline) - (write (odd? 1000)) + (write (odd? 100)) (newline) ) 'even 'odd) diff --git a/tests/test06-mutation.scm b/tests/test06-mutation.scm index 7be0f055..8dacb7fb 100644 --- a/tests/test06-mutation.scm +++ b/tests/test06-mutation.scm @@ -7,4 +7,3 @@ (set! e 10000) (write (+ e (* c 1000) (* a 100) (* b 10) d)) (newline))) - From 08d37049fd169ebec8c5df860cb9571fc2dec8db Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 17 Mar 2009 16:23:33 +0900 Subject: [PATCH 045/154] cleaning up allocation, hiding last details of sexp fields --- Makefile | 4 +- defaults.h | 18 ++++---- eval.c | 131 +++++++++++++++++++++++++++++++++++++++-------------- sexp.c | 107 +++++++++++++++++++++---------------------- sexp.h | 78 ++++++++++++++++++++++--------- 5 files changed, 221 insertions(+), 117 deletions(-) diff --git a/Makefile b/Makefile index 532a3cc2..b91568d8 100644 --- a/Makefile +++ b/Makefile @@ -10,10 +10,10 @@ GC_OBJ=./gc/gc.a $GC_OBJ: ./gc/alloc.c cd gc && make test -sexp.o: sexp.c sexp.h config.h Makefile +sexp.o: sexp.c sexp.h config.h defaults.h Makefile gcc -c $(CFLAGS) -o $@ $< -eval.o: eval.c debug.c eval.h sexp.h config.h Makefile +eval.o: eval.c debug.c eval.h sexp.h config.h defaults.h Makefile gcc -c $(CFLAGS) -o $@ $< # main.o: main.c eval.h sexp.h config.h Makefile diff --git a/defaults.h b/defaults.h index f48a538d..5215de72 100644 --- a/defaults.h +++ b/defaults.h @@ -41,14 +41,16 @@ #if USE_BOEHM #include "gc/include/gc.h" -#define SEXP_ALLOC GC_malloc -#define SEXP_ALLOC_ATOMIC GC_malloc_atomic -#define SEXP_REALLOC GC_realloc -#define SEXP_FREE GC_free +#define sexp_alloc GC_malloc +#define sexp_alloc_atomic GC_malloc_atomic +#define sexp_realloc GC_realloc +#define sexp_free(x) +#define sexp_deep_free(x) #else -#define SEXP_ALLOC malloc -#define SEXP_ALLOC_ATOMIC SEXP_ALLOC -#define SEXP_REALLOC realloc -#define SEXP_FREE free +#define sexp_alloc malloc +#define sexp_alloc_atomic sexp_alloc +#define sexp_realloc realloc +#define sexp_free free +void sexp_deep_free(sexp obj); #endif diff --git a/eval.c b/eval.c index 9da6bb0e..5b167112 100644 --- a/eval.c +++ b/eval.c @@ -65,8 +65,7 @@ static void env_define(sexp e, sexp key, sexp value) { static sexp extend_env (sexp e, sexp fv, int offset) { int i; - sexp e2 = (sexp) SEXP_ALLOC(sexp_sizeof(env)); - e2->tag = SEXP_ENV; + sexp e2 = sexp_alloc_type(env, SEXP_ENV); sexp_env_parent(e2) = e; sexp_env_bindings(e2) = SEXP_NULL; for (i=offset; sexp_pairp(fv); fv = sexp_cdr(fv), i--) @@ -98,11 +97,10 @@ static sexp sexp_flatten_dot (sexp ls) { static void shrink_bcode(sexp *bc, sexp_uint_t i) { sexp tmp; if (sexp_bytecode_length(*bc) != i) { - tmp = (sexp) SEXP_ALLOC(sexp_sizeof(bytecode) + i); - tmp->tag = SEXP_BYTECODE; + tmp = sexp_alloc_tagged(sexp_sizeof(bytecode) + i, SEXP_BYTECODE); sexp_bytecode_length(tmp) = i; memcpy(sexp_bytecode_data(tmp), sexp_bytecode_data(*bc), i); - SEXP_FREE(*bc); + sexp_free(*bc); *bc = tmp; } } @@ -110,14 +108,14 @@ static void shrink_bcode(sexp *bc, sexp_uint_t i) { static void expand_bcode(sexp *bc, sexp_uint_t *i, sexp_uint_t size) { sexp tmp; if (sexp_bytecode_length(*bc) < (*i)+size) { - tmp = (sexp) SEXP_ALLOC(sexp_sizeof(bytecode) - + sexp_bytecode_length(*bc)*2); - tmp->tag = SEXP_BYTECODE; + tmp = sexp_alloc_tagged(sexp_sizeof(bytecode) + + sexp_bytecode_length(*bc)*2, + SEXP_BYTECODE); sexp_bytecode_length(tmp) = sexp_bytecode_length(*bc)*2; memcpy(sexp_bytecode_data(tmp), sexp_bytecode_data(*bc), sexp_bytecode_length(*bc)); - SEXP_FREE(*bc); + sexp_free(*bc); *bc = tmp; } } @@ -140,8 +138,7 @@ static void emit_push(sexp *bc, sexp_uint_t *i, sexp obj) { static sexp sexp_make_procedure(sexp flags, sexp num_args, sexp bc, sexp vars) { - sexp proc = (sexp) SEXP_ALLOC(sexp_sizeof(procedure)); - proc->tag = SEXP_PROCEDURE; + sexp proc = sexp_alloc_type(procedure, SEXP_PROCEDURE); sexp_procedure_flags(proc) = (char) (sexp_uint_t) flags; sexp_procedure_num_args(proc) = (unsigned short) (sexp_uint_t) num_args; sexp_procedure_code(proc) = bc; @@ -150,8 +147,7 @@ static sexp sexp_make_procedure(sexp flags, sexp num_args, } static sexp sexp_make_macro (sexp p, sexp e) { - sexp mac = (sexp) SEXP_ALLOC(sexp_sizeof(macro)); - mac->tag = SEXP_MACRO; + sexp mac = sexp_alloc_type(macro, SEXP_MACRO); sexp_macro_env(mac) = e; sexp_macro_proc(mac) = p; return mac; @@ -166,13 +162,12 @@ sexp sexp_compile_error(char *message, sexp irritants) { } sexp sexp_expand_macro (sexp mac, sexp form, sexp e) { - sexp bc, res, *stack = SEXP_ALLOC(sizeof(sexp)*INIT_STACK_SIZE); + sexp bc, res, *stack = (sexp*) sexp_alloc(sizeof(sexp)*INIT_STACK_SIZE); sexp_uint_t i=0; /* fprintf(stderr, "expanding: "); */ /* sexp_write(form, cur_error_port); */ /* fprintf(stderr, "\n => "); */ - bc = (sexp) SEXP_ALLOC(sexp_sizeof(bytecode)+64); - bc->tag = SEXP_BYTECODE; + bc = sexp_alloc_tagged(sexp_sizeof(bytecode)+64, SEXP_BYTECODE); sexp_bytecode_length(bc) = 32; emit_push(&bc, &i, sexp_macro_env(mac)); emit_push(&bc, &i, e); @@ -184,11 +179,85 @@ sexp sexp_expand_macro (sexp mac, sexp form, sexp e) { res = vm(bc, e, stack, 0); sexp_write(res, cur_error_port); /* fprintf(stderr, "\n"); */ - SEXP_FREE(bc); - SEXP_FREE(stack); + sexp_free(bc); + sexp_free(stack); return res; } +/* sexp analyze(sexp x, sexp env) { */ +/* sexp op, cell; */ +/* loop: */ +/* if (sexp_pairp(x)) { */ +/* if (sexp_idp(sexp_car(x))) { */ +/* cell = env_cell(sexp_car(x), env); */ +/* if (! cell) return analyze_app(x, env); */ +/* op = sexp_cdr(cell); */ +/* if (sexp_corep(op)) { */ +/* switch (sexp_core_code(op)) { */ +/* case CORE_DEFINE: */ +/* if (sexp_env_global_p(env)) */ +/* return sexp_make_set(sexp_make_global_ref(sexp_cadr(x), env), */ +/* analyze(sexp_caddr(x), env)); */ +/* else */ +/* return sexp_compile_error("bad define location", sexp_list1(x)); */ +/* case CORE_SET: */ +/* return sexp_make_set(sexp_make_ref(sexp_cadr(x), env), */ +/* analyze(sexp_caddr(x), env)); */ +/* case CORE_LAMBDA: */ +/* return analyze_lambda(x, env); */ +/* case CORE_IF: */ +/* return sexp_make_cnd(analyze(sexp_car(x), env), */ +/* analyze(sexp_cadr(x), env), */ +/* (sexp_pairp(sexp_cddr(x)) */ +/* ? analyze(sexp_caddr(x), env) : SEXP_UNDEF)); */ +/* case CORE_BEGIN: */ +/* return sexp_make_seq(analyze_app(x, env)); */ +/* case CORE_QUOTE: */ +/* return sexp_make_lit(x); */ +/* default: */ +/* return sexp_compile_error("unknown core form", sexp_list1(op)); */ +/* } */ +/* } else if (sexp_macrop(op)) { */ +/* x = sexp_expand_macro(op, x, env); */ +/* goto loop; */ +/* } else { */ +/* return analyze_app(x, env); */ +/* } */ +/* } else { */ +/* return analyze_app(x, env); */ +/* } */ +/* } else if (sexp_symbolp(x)) { */ +/* return analyze_var_ref(x, env); */ +/* } else if (sexp_synclop(x)) { */ +/* env = sexp_synclo_env(x); */ +/* x = sexp_synclo_expr(x); */ +/* goto loop; */ +/* } else { */ +/* return x; */ +/* } */ +/* } */ + +/* sexp analyze_lambda(sexp x, sexp env) { */ +/* } */ + +/* sexp analyze_app(sexp x, sexp env) { */ +/* sexp res=SEXP_NULL; */ +/* for ( ; sexp_pairp(x); x=sexp_cdr(x)) */ +/* res = sexp_cons(analyze(sexp_car(x), env), res); */ +/* return sexp_nreverse(res); */ +/* } */ + +/* sexp compile(sexp x, sexp res) { */ +/* if (sexp_pairp(x)) */ +/* else if (sexp_lambdap(x)) */ +/* else if (sexp_seqp(x)) */ +/* else if (sexp_cndp(x)) */ +/* else if (sexp_refp(x)) */ +/* else if (sexp_setp(x)) */ +/* else if (sexp_litp(x)) */ +/* else */ +/* } */ + sexp analyze(sexp obj, sexp *bc, sexp_uint_t *i, sexp e, sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp) { int tmp1, tmp2; @@ -591,10 +660,9 @@ sexp make_opcode_procedure(sexp op, sexp_uint_t i, sexp e) { sexp_uint_t pos=0, d=0; if (i == sexp_opcode_num_args(op) && sexp_opcode_proc(op)) return sexp_opcode_proc(op); - bc = (sexp) SEXP_ALLOC(sexp_sizeof(bytecode)+INIT_BCODE_SIZE); + bc = sexp_alloc_tagged(sexp_sizeof(bytecode)+INIT_BCODE_SIZE, SEXP_BYTECODE); params = make_param_list(i); e = extend_env(e, params, -4); - bc->tag = SEXP_BYTECODE; sexp_bytecode_length(bc) = INIT_BCODE_SIZE; analyze_opcode(op, sexp_cons(op, params), &bc, &pos, e, params, SEXP_NULL, SEXP_NULL, &d, 0); @@ -609,9 +677,9 @@ sexp make_opcode_procedure(sexp op, sexp_uint_t i, sexp e) { sexp compile(sexp params, sexp obj, sexp e, sexp fv, sexp sv, int done_p) { sexp_uint_t i=0, j=0, d=0, define_ok=1, core; - sexp bc = (sexp) SEXP_ALLOC(sexp_sizeof(bytecode)+INIT_BCODE_SIZE); + sexp bc = sexp_alloc_tagged(sexp_sizeof(bytecode)+INIT_BCODE_SIZE, + SEXP_BYTECODE); sexp sv2 = set_vars(e, params, obj, SEXP_NULL), internals=SEXP_NULL, ls; - bc->tag = SEXP_BYTECODE; sexp_bytecode_length(bc) = INIT_BCODE_SIZE; /* box mutable vars */ for (ls=params, j=0; sexp_pairp(ls); ls=sexp_cdr(ls), j++) { @@ -1119,7 +1187,7 @@ sexp sexp_close_port (sexp port) { } sexp sexp_load (sexp source) { - sexp obj, res, *stack=SEXP_ALLOC(sizeof(sexp)*INIT_STACK_SIZE); + sexp obj, res, *stack = (sexp*) sexp_alloc(sizeof(sexp)*INIT_STACK_SIZE); int closep = 0; if (sexp_stringp(source)) { source = sexp_open_input_file(source); @@ -1132,7 +1200,7 @@ sexp sexp_load (sexp source) { res = SEXP_UNDEF; done: if (closep) sexp_close_port(source); - SEXP_FREE(stack); + sexp_free(stack); return res; } @@ -1225,8 +1293,7 @@ _PARAM("interaction-environment", (sexp)&interaction_environment, SEXP_ENV), sexp make_standard_env() { sexp_uint_t i; - sexp e = (sexp) SEXP_ALLOC(sexp_sizeof(env)); - e->tag = SEXP_ENV; + sexp e = sexp_alloc_type(env, SEXP_ENV); sexp_env_parent(e) = NULL; sexp_env_bindings(e) = SEXP_NULL; for (i=0; i<(sizeof(core_forms)/sizeof(core_forms[0])); i++) @@ -1245,9 +1312,9 @@ sexp eval_in_stack(sexp obj, sexp e, sexp* stack, sexp_sint_t top) { } sexp eval(sexp obj, sexp e) { - sexp* stack = (sexp*) SEXP_ALLOC(sizeof(sexp) * INIT_STACK_SIZE); + sexp* stack = (sexp*) sexp_alloc(sizeof(sexp) * INIT_STACK_SIZE); sexp res = eval_in_stack(obj, e, stack, 0); - SEXP_FREE(stack); + sexp_free(stack); return res; } @@ -1261,8 +1328,7 @@ void scheme_init() { cur_output_port = sexp_make_output_port(stdout); cur_error_port = sexp_make_output_port(stderr); the_compile_error_symbol = sexp_intern("compile-error"); - bc = (sexp) SEXP_ALLOC(sexp_sizeof(bytecode)+16); - bc->tag = SEXP_BYTECODE; + bc = sexp_alloc_tagged(sexp_sizeof(bytecode)+16, SEXP_BYTECODE); sexp_bytecode_length(bc) = 16; emit(&bc, &i, OP_RESUMECC); continuation_resumer = (sexp) bc; @@ -1290,11 +1356,10 @@ int main (int argc, char **argv) { sexp_uint_t i, quit=0, init_loaded=0; scheme_init(); - stack = (sexp*) SEXP_ALLOC(sizeof(sexp) * INIT_STACK_SIZE); + stack = (sexp*) sexp_alloc(sizeof(sexp) * INIT_STACK_SIZE); e = make_standard_env(); interaction_environment = e; - bc = (sexp) SEXP_ALLOC(sexp_sizeof(bytecode)+16); - bc->tag = SEXP_BYTECODE; + bc = sexp_alloc_tagged(sexp_sizeof(bytecode)+16, SEXP_BYTECODE); sexp_bytecode_length(bc) = 16; i = 0; emit_push(&bc, &i, SEXP_UNDEF); diff --git a/sexp.c b/sexp.c index ba515524..d01b2d50 100644 --- a/sexp.c +++ b/sexp.c @@ -51,38 +51,47 @@ static unsigned long symbol_table_primes[] = { static int symbol_table_prime_index = 0; static int symbol_table_count = 0; -void sexp_free (sexp obj) { +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 %d bytes for %d", + size ,tag); + res->tag = tag; + return res; +} + +#if ! USE_BOEHM +void sexp_deep_free (sexp obj) { int len, i; sexp *elts; if (sexp_pointerp(obj)) { switch (obj->tag) { case SEXP_PAIR: - sexp_free(sexp_car(obj)); - sexp_free(sexp_cdr(obj)); + 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; itag = SEXP_EXCEPTION; + sexp exn = sexp_alloc_type(exception, SEXP_EXCEPTION); sexp_exception_kind(exn) = kind; sexp_exception_message(exn) = message; sexp_exception_irritants(exn) = irritants; @@ -133,8 +142,7 @@ static sexp sexp_read_error(char *message, sexp irritants, sexp port) { /*************************** list utilities ***************************/ sexp sexp_cons(sexp head, sexp tail) { - sexp pair = SEXP_ALLOC(sexp_sizeof(pair)); - pair->tag = SEXP_PAIR; + sexp pair = sexp_alloc_type(pair, SEXP_PAIR); sexp_car(pair) = head; sexp_cdr(pair) = tail; return pair; @@ -224,18 +232,16 @@ sexp sexp_length(sexp ls) { /********************* strings, symbols, vectors **********************/ sexp sexp_make_flonum(double f) { - sexp x = SEXP_ALLOC(sexp_sizeof(flonum)); - x->tag = SEXP_FLONUM; + 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(sexp_sizeof(string)); + sexp s = sexp_alloc_type(string, SEXP_STRING); sexp_uint_t len = strlen(str); - char *mystr = SEXP_ALLOC(len+1); + char *mystr = sexp_alloc(len+1); memcpy(mystr, str, len+1); - s->tag = SEXP_STRING; sexp_string_length(s) = len; sexp_string_data(s) = mystr; return s; @@ -287,19 +293,18 @@ sexp sexp_intern(char *str) { if (symbol_table_count*5 > d*4) { fprintf(stderr, "resizing symbol table!!!!!\n"); - newtable = SEXP_ALLOC(symbol_table_primes[symbol_table_prime_index++] + newtable = sexp_alloc(symbol_table_primes[symbol_table_prime_index++] * sizeof(sexp)); /* XXXX rehash */ - SEXP_FREE(symbol_table); + sexp_free(symbol_table); symbol_table = newtable; } - sym = SEXP_ALLOC(sexp_sizeof(symbol)); + sym = sexp_alloc_type(symbol, SEXP_SYMBOL); len = strlen(str); - mystr = SEXP_ALLOC(len+1); + mystr = sexp_alloc(len+1); memcpy(mystr, str, len+1); mystr[len]=0; - sym->tag = SEXP_SYMBOL; sexp_symbol_length(sym) = len; sexp_symbol_data(sym) = mystr; symbol_table[cell] = sym; @@ -310,12 +315,11 @@ 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(sexp_sizeof(vector)); - x = (sexp*) SEXP_ALLOC(clen*sizeof(sexp)); + v = sexp_alloc_type(vector, SEXP_VECTOR); + x = (sexp*) sexp_alloc(clen*sizeof(sexp)); for (i=0; itag = SEXP_VECTOR; sexp_vector_length(v) = clen; sexp_vector_data(v) = x; return v; @@ -375,7 +379,7 @@ off_t sstream_seek(void *vec, off_t offset, int whence) { } int sstream_close(void *vec) { - sexp_free((sexp)vec); + sexp_deep_free((sexp)vec); return 0; } @@ -395,16 +399,14 @@ sexp sexp_get_output_string(sexp port) { #endif sexp sexp_make_input_port(FILE* in) { - sexp p = SEXP_ALLOC(sexp_sizeof(port)); - p->tag = SEXP_IPORT; + 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(sexp_sizeof(port)); - p->tag = SEXP_OPORT; + sexp p = sexp_alloc_type(port, SEXP_OPORT); sexp_port_stream(p) = out; sexp_port_line(p) = 0; return p; @@ -419,7 +421,7 @@ void sexp_write (sexp obj, sexp out) { if (! obj) { sexp_write_string("#", out); } else if (sexp_pointerp(obj)) { - switch (obj->tag) { + switch (sexp_tag(obj)) { case SEXP_PAIR: sexp_write_char('(', out); sexp_write(sexp_car(obj), out); @@ -474,7 +476,7 @@ void sexp_write (sexp obj, sexp out) { str = sexp_string_data(obj); /* ... FALLTHROUGH ... */ case SEXP_SYMBOL: - if (obj->tag != SEXP_STRING) { + if (! sexp_stringp(obj)) { i = sexp_symbol_length(obj); str = sexp_symbol_data(obj); } @@ -483,7 +485,7 @@ void sexp_write (sexp obj, sexp out) { sexp_write_char('\\', out); sexp_write_char(str[0], out); } - if (obj->tag == SEXP_STRING) + if (sexp_stringp(obj)) sexp_write_char('"', out); break; } @@ -530,12 +532,12 @@ char* sexp_read_string(sexp in) { char *buf, *tmp, *res; int c, len, size=128; - buf = SEXP_ALLOC(size); /* XXXX grow! */ + 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); + sexp_free(buf); return NULL; } else if (c == '\\') { c=sexp_read_char(in); @@ -551,9 +553,9 @@ char* sexp_read_string(sexp in) { *tmp++ = '\0'; len = tmp - buf; - res = SEXP_ALLOC(len); + res = sexp_alloc(len); memcpy(res, buf, len); - SEXP_FREE(buf); + sexp_free(buf); return res; } @@ -561,7 +563,7 @@ char* sexp_read_symbol(sexp in, int init) { char *buf, *tmp, *res; int c, len, size=128; - buf = SEXP_ALLOC(size); + buf = sexp_alloc(size); tmp = buf; if (init != EOF) @@ -578,9 +580,9 @@ char* sexp_read_symbol(sexp in, int init) { *tmp++ = '\0'; len = tmp - buf; - res = SEXP_ALLOC(len); + res = sexp_alloc(len); memcpy(res, buf, len); - SEXP_FREE(buf); + sexp_free(buf); return res; } @@ -666,7 +668,7 @@ sexp sexp_read_raw (sexp in) { case '"': str = sexp_read_string(in); res = sexp_make_string(str); - SEXP_FREE(str); + sexp_free(str); break; case '(': res = SEXP_NULL; @@ -679,7 +681,7 @@ sexp sexp_read_raw (sexp in) { } else { tmp = sexp_read_raw(in); if (sexp_read_raw(in) != SEXP_CLOSE) { - sexp_free(res); + sexp_deep_free(res); return sexp_read_error("multiple tokens in dotted tail", SEXP_NULL, in); } else { @@ -695,7 +697,7 @@ sexp sexp_read_raw (sexp in) { } } if (tmp != SEXP_CLOSE) { - sexp_free(res); + sexp_deep_free(res); return sexp_read_error("missing trailing ')'", SEXP_NULL, in); } res = (sexp_pairp(res) ? sexp_nreverse(res) : res); @@ -759,7 +761,7 @@ sexp sexp_read_raw (sexp in) { res = sexp_read(in); if (! sexp_listp(res)) { if (! sexp_exceptionp(res)) { - sexp_free(res); + sexp_deep_free(res); return sexp_read_error("dotted list not allowed in vector syntax", SEXP_NULL, in); @@ -784,7 +786,7 @@ sexp sexp_read_raw (sexp in) { sexp_push_char(c1, in); str = sexp_read_symbol(in, '.'); res = sexp_intern(str); - SEXP_FREE(str); + sexp_free(str); } break; case ')': @@ -802,7 +804,7 @@ sexp sexp_read_raw (sexp in) { sexp_push_char(c2, in); str = sexp_read_symbol(in, c1); res = sexp_intern(str); - SEXP_FREE(str); + sexp_free(str); } break; case '0': case '1': case '2': case '3': case '4': @@ -813,7 +815,7 @@ sexp sexp_read_raw (sexp in) { default: str = sexp_read_symbol(in, c1); res = sexp_intern(str); - SEXP_FREE(str); + sexp_free(str); break; } return res; @@ -832,8 +834,8 @@ 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_free(s); - sexp_free(in); + sexp_deep_free(s); + sexp_deep_free(in); return res; } @@ -843,15 +845,14 @@ void sexp_init() { #if USE_BOEHM GC_init(); #endif - symbol_table = SEXP_ALLOC(symbol_table_primes[0]*sizeof(sexp)); + 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(sexp_sizeof(vector)); - the_empty_vector->tag = SEXP_VECTOR; + the_empty_vector = sexp_alloc_type(vector, SEXP_VECTOR); sexp_vector_length(the_empty_vector) = 0; sexp_vector_data(the_empty_vector) = NULL; } diff --git a/sexp.h b/sexp.h index ba1afd88..9bc01269 100644 --- a/sexp.h +++ b/sexp.h @@ -10,6 +10,7 @@ #include #include #include +#include #include "config.h" #include "defaults.h" @@ -17,7 +18,7 @@ /* tagging system * bits end in 00: pointer * 01: fixnum - * 011: symbol + * 011: * 111: immediate symbol * 0110: char * 1110: other immediate object (NULL, TRUE, FALSE) @@ -54,10 +55,17 @@ enum sexp_types { /* the following are used only by the evaluator */ SEXP_PROCEDURE, SEXP_MACRO, + SEXP_SYNCLO, SEXP_ENV, SEXP_BYTECODE, SEXP_CORE, SEXP_OPCODE, + SEXP_LAMBDA, + SEXP_CND, + SEXP_REF, + SEXP_SET, + SEXP_SEQ, + SEXP_LIT, }; typedef unsigned long sexp_uint_t; @@ -68,6 +76,7 @@ typedef struct sexp_struct *sexp; struct sexp_struct { sexp_tag_t tag; union { + /* basic types */ double flonum; struct { sexp car, cdr; @@ -92,6 +101,7 @@ struct sexp_struct { struct { sexp kind, message, irritants, file, line; } exception; + /* runtime types */ struct { char flags; sexp parent, bindings; @@ -110,7 +120,7 @@ struct sexp_struct { } macro; struct { sexp env, free_vars, expr; - } sc; + } synclo; struct { unsigned char op_class, code, num_args, flags, arg1_type, arg2_type, inverse; @@ -121,13 +131,37 @@ struct sexp_struct { char code; char *name; } core; + /* ast types */ + struct { + sexp name, params, flags, body, fv, sv; + } lambda; + struct { + sexp test, pass, fail; + } cnd; + struct { + sexp var, value; + } set; + struct { + sexp var, value; + } ref; + struct { + sexp ls; + } seq; + struct { + sexp x; + } lit; } value; }; -#define sexp_sizeof_field(field) (sizeof((sexp)NULL)->value.field) -#define sexp_sizeof(field) (sizeof(struct sexp_struct)-sexp_sizeof_field(exception)+sexp_sizeof_field(field)) +/* #define offsetof(st, m) ((size_t) ((char*)&((st*)(0))->m - (char*)0)) */ -#define SEXP_MAKE_IMMEDIATE(n) ((sexp) ((n<value.x)) + +#define sexp_alloc_type(type, tag) sexp_alloc_tagged(sexp_sizeof(type), tag) + +#define SEXP_MAKE_IMMEDIATE(n) ((sexp) ((n<tag == (t)) +#define sexp_tag(x) ((x)->tag) -#define sexp_pairp(x) (SEXP_CHECK_TAG(x, SEXP_PAIR)) -#define sexp_stringp(x) (SEXP_CHECK_TAG(x, SEXP_STRING)) -#define sexp_lsymbolp(x) (SEXP_CHECK_TAG(x, SEXP_SYMBOL)) -#define sexp_vectorp(x) (SEXP_CHECK_TAG(x, SEXP_VECTOR)) -#define sexp_flonump(x) (SEXP_CHECK_TAG(x, SEXP_FLONUM)) -#define sexp_iportp(x) (SEXP_CHECK_TAG(x, SEXP_IPORT)) -#define sexp_oportp(x) (SEXP_CHECK_TAG(x, SEXP_OPORT)) -#define sexp_exceptionp(x) (SEXP_CHECK_TAG(x, SEXP_EXCEPTION)) -#define sexp_procedurep(x) (SEXP_CHECK_TAG(x, SEXP_PROCEDURE)) -#define sexp_envp(x) (SEXP_CHECK_TAG(x, SEXP_ENV)) -#define sexp_bytecodep(x) (SEXP_CHECK_TAG(x, SEXP_BYTECODE)) -#define sexp_corep(x) (SEXP_CHECK_TAG(x, SEXP_CORE)) -#define sexp_opcodep(x) (SEXP_CHECK_TAG(x, SEXP_OPCODE)) -#define sexp_macrop(x) (SEXP_CHECK_TAG(x, SEXP_MACRO)) +#define sexp_check_tag(x,t) (sexp_pointerp(x) && (sexp_tag(x) == (t))) + +#define sexp_pairp(x) (sexp_check_tag(x, SEXP_PAIR)) +#define sexp_stringp(x) (sexp_check_tag(x, SEXP_STRING)) +#define sexp_lsymbolp(x) (sexp_check_tag(x, SEXP_SYMBOL)) +#define sexp_vectorp(x) (sexp_check_tag(x, SEXP_VECTOR)) +#define sexp_flonump(x) (sexp_check_tag(x, SEXP_FLONUM)) +#define sexp_iportp(x) (sexp_check_tag(x, SEXP_IPORT)) +#define sexp_oportp(x) (sexp_check_tag(x, SEXP_OPORT)) +#define sexp_exceptionp(x) (sexp_check_tag(x, SEXP_EXCEPTION)) +#define sexp_procedurep(x) (sexp_check_tag(x, SEXP_PROCEDURE)) +#define sexp_envp(x) (sexp_check_tag(x, SEXP_ENV)) +#define sexp_bytecodep(x) (sexp_check_tag(x, SEXP_BYTECODE)) +#define sexp_corep(x) (sexp_check_tag(x, SEXP_CORE)) +#define sexp_opcodep(x) (sexp_check_tag(x, SEXP_OPCODE)) +#define sexp_macrop(x) (sexp_check_tag(x, SEXP_MACRO)) #define sexp_symbolp(x) (sexp_isymbolp(x) || sexp_lsymbolp(x)) #define sexp_make_boolean(x) ((x) ? SEXP_TRUE : SEXP_FALSE) @@ -293,6 +329,7 @@ void sexp_printf(sexp port, sexp fmt, ...); #define sexp_cadddr(x) (sexp_cadr(sexp_cddr(x))) #define sexp_cddddr(x) (sexp_cddr(sexp_cddr(x))) +sexp sexp_alloc_tagged(size_t size, sexp_uint_t tag); sexp sexp_cons(sexp head, sexp tail); int sexp_listp(sexp obj); int sexp_list_index(sexp ls, sexp elt); @@ -311,7 +348,6 @@ sexp sexp_make_vector(sexp len, sexp dflt); sexp sexp_list_to_vector(sexp ls); sexp sexp_vector(int count, ...); void sexp_write(sexp obj, sexp out); -void sexp_free(sexp obj); char* sexp_read_string(sexp in); char* sexp_read_symbol(sexp in, int init); sexp sexp_read_number(sexp in, int base); From 4d55fd31803c985c044baf28717e00a45ba9d495 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Wed, 25 Mar 2009 15:24:52 +0900 Subject: [PATCH 046/154] mid-rewrite --- debug.c | 6 +- eval.c | 1659 +++++++++++++++++++++++++++++++++++-------------------- eval.h | 42 +- sexp.c | 14 +- sexp.h | 158 ++++-- 5 files changed, 1213 insertions(+), 666 deletions(-) diff --git a/debug.c b/debug.c index 21021e5c..bb80564c 100644 --- a/debug.c +++ b/debug.c @@ -7,7 +7,7 @@ static const char* reverse_opcode_names[] = "FCALL0", "FCALL1", "FCALL2", "FCALL3", "FCALLN", "JUMP-UNLESS", "JUMP", "RET", "DONE", "PARAMETER", - "STACK-REF", "STACK-SET", "CLOSURE-REF", + "LOCAL-REF", "LOCAL-SET", "CLOSURE-REF", "VECTOR-REF", "VECTOR-SET", "STRING-REF", "STRING-SET", "MAKE-PROCEDURE", "MAKE-VECTOR", "PUSH", "DROP", "PAIRP", "NULLP", "VECTORP", "INTEGERP", "SYMBOLP", "STRINGP", "CHARP", "EOFP", "PROCEDUREP", "IPORTP", @@ -27,8 +27,8 @@ void disasm (sexp bc) { fprintf(stderr, " %d ", opcode); } switch (opcode) { - case OP_STACK_REF: - case OP_STACK_SET: + case OP_LOCAL_REF: + case OP_LOCAL_SET: case OP_CLOSURE_REF: case OP_PARAMETER: fprintf(stderr, "%ld", (long) ((sexp*)ip)[0]); diff --git a/eval.c b/eval.c index 5b167112..b51d5034 100644 --- a/eval.c +++ b/eval.c @@ -10,7 +10,7 @@ static int scheme_initialized_p = 0; static sexp cur_input_port, cur_output_port, cur_error_port; static sexp exception_handler_cell; -static sexp continuation_resumer; +static sexp continuation_resumer, final_resumer; static sexp interaction_environment; static sexp the_compile_error_symbol; @@ -22,6 +22,32 @@ static sexp the_compile_error_symbol; #define disasm(...) #endif +/*************************** prototypes *******************************/ + +sexp analyze (sexp x, sexp env); +sexp analyze_lambda (sexp x, sexp env); +sexp analyze_seq (sexp ls, sexp env); +sexp analyze_if (sexp x, sexp env); +sexp analyze_app (sexp x, sexp env); +sexp analyze_define (sexp x, sexp env); +sexp analyze_var_ref (sexp x, sexp env); +sexp analyze_set (sexp x, sexp env); + +sexp_uint_t sexp_context_make_label (sexp context); +void sexp_context_patch_label (sexp context, sexp_uint_t label); +void compile_one (sexp x, sexp context); +void compile_lit (sexp value, sexp context); +void compile_seq (sexp app, sexp context); +void compile_cnd (sexp cnd, sexp context); +void compile_ref (sexp ref, sexp context, int unboxp); +void compile_non_global_ref (sexp name, sexp loc, sexp lambda, sexp fv, + sexp context, int unboxp); +void compile_set (sexp set, sexp context); +void compile_app (sexp app, sexp context); +void compile_opcode_app (sexp app, sexp context); +void compile_general_app (sexp app, sexp context); +void compile_lambda (sexp lambda, sexp context); + /********************** environment utilities ***************************/ static sexp env_cell(sexp e, sexp key) { @@ -37,10 +63,10 @@ static sexp env_cell(sexp e, sexp key) { return NULL; } -static sexp env_cell_create(sexp e, sexp key) { +static sexp env_cell_create(sexp e, sexp key, sexp value) { sexp cell = env_cell(e, key); if (! cell) { - cell = sexp_cons(key, SEXP_UNDEF); + cell = sexp_cons(key, value); while (sexp_env_parent(e)) e = sexp_env_parent(e); sexp_env_bindings(e) = sexp_cons(cell, sexp_env_bindings(e)); @@ -59,20 +85,20 @@ static int env_global_p (sexp e, sexp id) { } static void env_define(sexp e, sexp key, sexp value) { - sexp cell = env_cell_create(e, key); - sexp_cdr(cell) = value; + sexp cell = sexp_assq(key, sexp_env_bindings(e)); + if (cell != SEXP_FALSE) + sexp_cdr(cell) = value; + else + sexp_push(sexp_env_bindings(e), sexp_cons(key, value)); } -static sexp extend_env (sexp e, sexp fv, int offset) { - int i; - sexp e2 = sexp_alloc_type(env, SEXP_ENV); - sexp_env_parent(e2) = e; - sexp_env_bindings(e2) = SEXP_NULL; - for (i=offset; sexp_pairp(fv); fv = sexp_cdr(fv), i--) - sexp_env_bindings(e2) - = sexp_cons(sexp_cons(sexp_car(fv), sexp_make_integer(i)), - sexp_env_bindings(e2)); - return e2; +static sexp extend_env (sexp env, sexp vars, sexp value) { + sexp e = sexp_alloc_type(env, SEXP_ENV); + sexp_env_parent(e) = env; + sexp_env_bindings(e) = SEXP_NULL; + for ( ; sexp_pairp(vars); vars = sexp_cdr(vars)) + sexp_push(sexp_env_bindings(e), sexp_cons(sexp_car(vars), value)); + return e; } static int core_code (sexp e, sexp sym) { @@ -84,7 +110,7 @@ static int core_code (sexp e, sexp sym) { static sexp sexp_reverse_flatten_dot (sexp ls) { sexp res; for (res=SEXP_NULL; sexp_pairp(ls); ls=sexp_cdr(ls)) - res = sexp_cons(sexp_car(ls), res); + sexp_push(res, sexp_car(ls)); return (sexp_nullp(ls) ? res : sexp_cons(ls, res)); } @@ -94,46 +120,46 @@ static sexp sexp_flatten_dot (sexp ls) { /************************* bytecode utilities ***************************/ -static void shrink_bcode(sexp *bc, sexp_uint_t i) { +static void shrink_bcode(sexp context, sexp_uint_t i) { sexp tmp; - if (sexp_bytecode_length(*bc) != i) { + if (sexp_bytecode_length(sexp_context_bc(context)) != i) { tmp = sexp_alloc_tagged(sexp_sizeof(bytecode) + i, SEXP_BYTECODE); sexp_bytecode_length(tmp) = i; - memcpy(sexp_bytecode_data(tmp), sexp_bytecode_data(*bc), i); - sexp_free(*bc); - *bc = tmp; + memcpy(sexp_bytecode_data(tmp), sexp_bytecode_data(sexp_context_bc(context)), i); + sexp_context_bc(context) = tmp; } } -static void expand_bcode(sexp *bc, sexp_uint_t *i, sexp_uint_t size) { +static void expand_bcode(sexp context, sexp_uint_t size) { sexp tmp; - if (sexp_bytecode_length(*bc) < (*i)+size) { + if (sexp_bytecode_length(sexp_context_bc(context)) + < (sexp_context_pos(context))+size) { tmp = sexp_alloc_tagged(sexp_sizeof(bytecode) - + sexp_bytecode_length(*bc)*2, + + sexp_bytecode_length(sexp_context_bc(context))*2, SEXP_BYTECODE); - sexp_bytecode_length(tmp) = sexp_bytecode_length(*bc)*2; + sexp_bytecode_length(tmp) + = sexp_bytecode_length(sexp_context_bc(context))*2; memcpy(sexp_bytecode_data(tmp), - sexp_bytecode_data(*bc), - sexp_bytecode_length(*bc)); - sexp_free(*bc); - *bc = tmp; + sexp_bytecode_data(sexp_context_bc(context)), + sexp_bytecode_length(sexp_context_bc(context))); + sexp_context_bc(context) = tmp; } } -static void emit(sexp *bc, sexp_uint_t *i, char c) { - expand_bcode(bc, i, 1); - sexp_bytecode_data(*bc)[(*i)++] = c; +static void emit(char c, sexp context) { + expand_bcode(context, 1); + sexp_bytecode_data(sexp_context_bc(context))[sexp_context_pos(context)++] = c; } -static void emit_word(sexp *bc, sexp_uint_t *i, sexp_uint_t val) { - expand_bcode(bc, i, sizeof(sexp)); - *((sexp_uint_t*)(&(sexp_bytecode_data(*bc)[*i]))) = val; - *i += sizeof(sexp_uint_t); +static void emit_word(sexp_uint_t val, sexp context) { + expand_bcode(context, sizeof(sexp)); + *((sexp_uint_t*)(&(sexp_bytecode_data(sexp_context_bc(context))[sexp_context_pos(context)]))) = val; + sexp_context_pos(context) += sizeof(sexp); } -static void emit_push(sexp *bc, sexp_uint_t *i, sexp obj) { - emit(bc, i, OP_PUSH); - emit_word(bc, i, (sexp_uint_t)obj); +static void emit_push(sexp obj, sexp context) { + emit(OP_PUSH, context); + emit_word((sexp_uint_t)obj, context); } static sexp sexp_make_procedure(sexp flags, sexp num_args, @@ -153,498 +179,913 @@ static sexp sexp_make_macro (sexp p, sexp e) { return mac; } +static sexp sexp_make_set(sexp var, sexp value) { + sexp res = sexp_alloc_type(set, SEXP_SET); + sexp_set_var(res) = var; + sexp_set_value(res) = value; + return res; +} + +static sexp sexp_make_ref(sexp name, sexp loc) { + sexp res = sexp_alloc_type(ref, SEXP_REF); + sexp_ref_name(res) = name; + sexp_ref_loc(res) = loc; + return res; +} + +static sexp sexp_make_cnd(sexp test, sexp pass, sexp fail) { + sexp res = sexp_alloc_type(cnd, SEXP_CND); + sexp_cnd_test(res) = test; + sexp_cnd_pass(res) = pass; + sexp_cnd_fail(res) = fail; + return res; +} + +static sexp sexp_make_lit(sexp value) { + sexp res = sexp_alloc_type(lit, SEXP_LIT); + sexp_lit_value(res) = value; + return res; +} + +static sexp sexp_new_context(sexp *stack) { + sexp res = sexp_alloc_type(context, SEXP_CONTEXT); + if (! stack) + stack = (sexp*) sexp_alloc(sizeof(sexp)*INIT_STACK_SIZE); + sexp_context_bc(res) + = sexp_alloc_tagged(sexp_sizeof(bytecode)+INIT_BCODE_SIZE, SEXP_BYTECODE); + sexp_bytecode_length(sexp_context_bc(res)) = INIT_BCODE_SIZE; + sexp_context_stack(res) = stack; + sexp_context_depth(res) = 0; + sexp_context_pos(res) = 0; + return res; +} + +static sexp sexp_extend_context(sexp context, sexp lambda) { + sexp ctx = sexp_new_context(sexp_context_stack(context)); + sexp_context_lambda(ctx) = lambda; + return ctx; +} + +static int sexp_idp (sexp x) { + while (sexp_synclop(x)) + x = sexp_synclo_expr(x); + return sexp_symbolp(x); +} + /************************* the compiler ***************************/ -sexp sexp_compile_error(char *message, sexp irritants) { +static sexp sexp_compile_error(char *message, sexp irritants) { return sexp_make_exception(the_compile_error_symbol, sexp_make_string(message), irritants, SEXP_FALSE, SEXP_FALSE); } -sexp sexp_expand_macro (sexp mac, sexp form, sexp e) { - sexp bc, res, *stack = (sexp*) sexp_alloc(sizeof(sexp)*INIT_STACK_SIZE); - sexp_uint_t i=0; -/* fprintf(stderr, "expanding: "); */ -/* sexp_write(form, cur_error_port); */ -/* fprintf(stderr, "\n => "); */ - bc = sexp_alloc_tagged(sexp_sizeof(bytecode)+64, SEXP_BYTECODE); - sexp_bytecode_length(bc) = 32; - emit_push(&bc, &i, sexp_macro_env(mac)); - emit_push(&bc, &i, e); - emit_push(&bc, &i, form); - emit_push(&bc, &i, sexp_macro_proc(mac)); - emit(&bc, &i, OP_CALL); - emit_word(&bc, &i, (sexp_uint_t) sexp_make_integer(3)); - emit(&bc, &i, OP_DONE); - res = vm(bc, e, stack, 0); - sexp_write(res, cur_error_port); -/* fprintf(stderr, "\n"); */ - sexp_free(bc); - sexp_free(stack); +/* sexp expand_macro (sexp mac, sexp form, sexp e) { */ +/* sexp bc, res, *stack = (sexp*) sexp_alloc(sizeof(sexp)*INIT_STACK_SIZE); */ +/* sexp_uint_t i=0; */ +/* /\* fprintf(stderr, "expanding: "); *\/ */ +/* /\* sexp_write(form, cur_error_port); *\/ */ +/* /\* fprintf(stderr, "\n => "); *\/ */ +/* bc = sexp_alloc_tagged(sexp_sizeof(bytecode)+64, SEXP_BYTECODE); */ +/* sexp_bytecode_length(bc) = 32; */ +/* emit_push(&bc, &i, sexp_macro_env(mac)); */ +/* emit_push(&bc, &i, e); */ +/* emit_push(&bc, &i, form); */ +/* emit_push(&bc, &i, sexp_macro_proc(mac)); */ +/* emit(&bc, &i, OP_CALL); */ +/* emit_word(&bc, &i, (sexp_uint_t) sexp_make_integer(3)); */ +/* emit(&bc, &i, OP_DONE); */ +/* res = vm(bc, e, stack, 0); */ +/* sexp_write(res, cur_error_port); */ +/* /\* fprintf(stderr, "\n"); *\/ */ +/* sexp_free(bc); */ +/* sexp_free(stack); */ +/* return res; */ +/* } */ + +#define analyze_check_exception(x) do {if (sexp_exceptionp(x)) \ + return (x); \ + } while (0) + +#define analyze_bind(var, x, env) do {(var) = analyze(x,env); \ + analyze_check_exception(var); \ + } while (0) + +sexp analyze (sexp x, sexp env) { + sexp op, cell, res; + loop: + if (sexp_pairp(x)) { + if (sexp_idp(sexp_car(x))) { + cell = env_cell(env, sexp_car(x)); + if (! cell) return analyze_app(x, env); + op = sexp_cdr(cell); + if (sexp_corep(op)) { + switch (sexp_core_code(op)) { + case CORE_DEFINE: + res = analyze_define(x, env); + break; + case CORE_SET: + res = analyze_set(x, env); + break; + case CORE_LAMBDA: + res = analyze_lambda(x, env); + break; + case CORE_IF: + res = analyze_if(x, env); + break; + case CORE_BEGIN: + res = analyze_seq(x, env); + break; + case CORE_QUOTE: + res = sexp_make_lit(x); + break; + default: + res = sexp_compile_error("unknown core form", sexp_list1(op)); + break; + } + } else if (sexp_macrop(op)) { + /* x = expand_macro(op, x, env); */ + /* goto loop; */ + res = sexp_compile_error("macros not yet supported", sexp_list1(x)); + } else { + res = analyze_app(x, env); + } + } else { + res = analyze_app(x, env); + } + } else if (sexp_symbolp(x)) { + res = analyze_var_ref(x, env); + } else if (sexp_synclop(x)) { + env = sexp_synclo_env(x); + x = sexp_synclo_expr(x); + goto loop; + } else { + res = x; + } return res; } -/* sexp analyze(sexp x, sexp env) { */ -/* sexp op, cell; */ -/* loop: */ -/* if (sexp_pairp(x)) { */ -/* if (sexp_idp(sexp_car(x))) { */ -/* cell = env_cell(sexp_car(x), env); */ -/* if (! cell) return analyze_app(x, env); */ -/* op = sexp_cdr(cell); */ -/* if (sexp_corep(op)) { */ -/* switch (sexp_core_code(op)) { */ -/* case CORE_DEFINE: */ -/* if (sexp_env_global_p(env)) */ -/* return sexp_make_set(sexp_make_global_ref(sexp_cadr(x), env), */ -/* analyze(sexp_caddr(x), env)); */ -/* else */ -/* return sexp_compile_error("bad define location", sexp_list1(x)); */ -/* case CORE_SET: */ -/* return sexp_make_set(sexp_make_ref(sexp_cadr(x), env), */ -/* analyze(sexp_caddr(x), env)); */ -/* case CORE_LAMBDA: */ -/* return analyze_lambda(x, env); */ -/* case CORE_IF: */ -/* return sexp_make_cnd(analyze(sexp_car(x), env), */ -/* analyze(sexp_cadr(x), env), */ -/* (sexp_pairp(sexp_cddr(x)) */ -/* ? analyze(sexp_caddr(x), env) : SEXP_UNDEF)); */ -/* case CORE_BEGIN: */ -/* return sexp_make_seq(analyze_app(x, env)); */ -/* case CORE_QUOTE: */ -/* return sexp_make_lit(x); */ -/* default: */ -/* return sexp_compile_error("unknown core form", sexp_list1(op)); */ -/* } */ -/* } else if (sexp_macrop(op)) { */ -/* x = sexp_expand_macro(op, x, env); */ -/* goto loop; */ -/* } else { */ -/* return analyze_app(x, env); */ -/* } */ -/* } else { */ -/* return analyze_app(x, env); */ -/* } */ -/* } else if (sexp_symbolp(x)) { */ -/* return analyze_var_ref(x, env); */ -/* } else if (sexp_synclop(x)) { */ -/* env = sexp_synclo_env(x); */ -/* x = sexp_synclo_expr(x); */ -/* goto loop; */ -/* } else { */ -/* return x; */ -/* } */ -/* } */ - -/* sexp analyze_lambda(sexp x, sexp env) { */ -/* } */ - -/* sexp analyze_app(sexp x, sexp env) { */ -/* sexp res=SEXP_NULL; */ -/* for ( ; sexp_pairp(x); x=sexp_cdr(x)) */ -/* res = sexp_cons(analyze(sexp_car(x), env), res); */ -/* return sexp_nreverse(res); */ -/* } */ - -/* sexp compile(sexp x, sexp res) { */ -/* if (sexp_pairp(x)) */ -/* else if (sexp_lambdap(x)) */ -/* else if (sexp_seqp(x)) */ -/* else if (sexp_cndp(x)) */ -/* else if (sexp_refp(x)) */ -/* else if (sexp_setp(x)) */ -/* else if (sexp_litp(x)) */ -/* else */ -/* } */ - -sexp analyze(sexp obj, sexp *bc, sexp_uint_t *i, sexp e, - sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp) { - int tmp1, tmp2; - sexp o1, o2, e2, cell, exn; - - loop: - if (sexp_pairp(obj)) { - if (sexp_symbolp(sexp_car(obj))) { - o1 = env_cell(e, sexp_car(obj)); - if (! o1) { - return analyze_app(obj, bc, i, e, params, fv, sv, d, tailp); - } - o1 = sexp_cdr(o1); - if (sexp_corep(o1)) { - switch (sexp_core_code(o1)) { - case CORE_LAMBDA: - return analyze_lambda(SEXP_FALSE, sexp_cadr(obj), sexp_cddr(obj), - bc, i, e, params, fv, sv, d, tailp); - case CORE_DEFINE_SYNTAX: - o2 = eval(sexp_caddr(obj), e); - if (sexp_exceptionp(o2)) return o2; - env_define(e, sexp_cadr(obj), sexp_make_macro(o2, e)); - emit_push(bc, i, SEXP_UNDEF); - (*d)++; - break; - case CORE_DEFINE: - if ((sexp_core_code(o1) == CORE_DEFINE) - && sexp_pairp(sexp_cadr(obj))) { - o2 = sexp_car(sexp_cadr(obj)); - exn = analyze_lambda(sexp_caadr(obj), sexp_cdadr(obj), - sexp_cddr(obj), - bc, i, e, params, fv, sv, d, 0); - } else { - o2 = sexp_cadr(obj); - exn = analyze(sexp_caddr(obj), bc, i, e, params, fv, sv, d, 0); - } - if (sexp_exceptionp(exn)) return exn; - if (sexp_env_global_p(e)) { - cell = env_cell_create(e, o2); - emit_push(bc, i, cell); - emit(bc, i, OP_SET_CDR); - } else { - cell = env_cell(e, o2); - if (! cell || ! sexp_integerp(sexp_cdr(cell))) { - return sexp_compile_error("define in bad position", - sexp_list1(obj)); - } else { - emit(bc, i, OP_STACK_SET); - emit_word(bc, i, (*d)+1-sexp_unbox_integer(sexp_cdr(cell))); - } - } - (*d)++; - break; - case CORE_SET: - exn = analyze(sexp_caddr(obj), bc, i, e, params, fv, sv, d, 0); - if (sexp_exceptionp(exn)) return exn; - if (sexp_list_index(sv, sexp_cadr(obj)) >= 0) { - analyze_var_ref(sexp_cadr(obj), bc, i, e, params, fv, SEXP_NULL, d); - emit(bc, i, OP_SET_CAR); - (*d)--; - } else { - cell = env_cell_create(e, sexp_cadr(obj)); - emit_push(bc, i, cell); - emit(bc, i, OP_SET_CDR); - } - break; - case CORE_BEGIN: - return - analyze_sequence(sexp_cdr(obj), bc, i, e, params, fv, sv, d, tailp); - case CORE_IF: - exn = analyze(sexp_cadr(obj), bc, i, e, params, fv, sv, d, 0); - if (sexp_exceptionp(exn)) return exn; - emit(bc, i, OP_JUMP_UNLESS); /* jumps if test fails */ - (*d)--; - tmp1 = *i; - emit(bc, i, 0); - exn = analyze(sexp_caddr(obj), bc, i, e, params, fv, sv, d, tailp); - if (sexp_exceptionp(exn)) return exn; - emit(bc, i, OP_JUMP); - (*d)--; - tmp2 = *i; - emit(bc, i, 0); - ((signed char*) sexp_bytecode_data(*bc))[tmp1] = (*i)-tmp1; - if (sexp_pairp(sexp_cdddr(obj))) { - exn = analyze(sexp_cadddr(obj), bc, i, e, params, fv, sv, d, tailp); - if (sexp_exceptionp(exn)) return exn; - } else { - emit_push(bc, i, SEXP_UNDEF); - (*d)++; - } - ((signed char*) sexp_bytecode_data(*bc))[tmp2] = (*i)-tmp2; - break; - case CORE_QUOTE: - emit_push(bc, i, sexp_cadr(obj)); - (*d)++; - break; - default: - return sexp_compile_error("unknown core form", sexp_list1(o1)); - } - } else if (sexp_opcodep(o1)) { - return analyze_opcode(o1, obj, bc, i, e, params, fv, sv, d, tailp); - } else if (sexp_macrop(o1)) { - obj = sexp_expand_macro(o1, obj, e); - if (sexp_exceptionp(obj)) return obj; - goto loop; - } else { - /* general procedure call */ - return analyze_app(obj, bc, i, e, params, fv, sv, d, tailp); - } - } else if (sexp_pairp(sexp_car(obj))) { -#if USE_FAST_LET - o2 = env_cell(e, sexp_caar(obj)); - if (o2 - && sexp_corep(sexp_cdr(o2)) - && (sexp_core_code(o2) == CORE_LAMBDA) - && sexp_listp(sexp_cadr(sexp_car(obj)))) { - /* let */ - tmp1 = sexp_unbox_integer(sexp_length(sexp_cadar(obj))); - /* push params as local stack variables */ - for (o2=sexp_reverse(sexp_cdr(obj)); sexp_pairp(o2); o2=sexp_cdr(o2)) { - exn = analyze(sexp_car(o2), bc, i, e, params, fv, sv, d, 0); - if (sexp_exceptionp(exn)) return exn; - } - /* analyze the body in a new local env */ - e2 = extend_env(e, sexp_cadar(obj), (*d)+(tmp1-1)); - params = sexp_append(sexp_cadar(obj), params); - exn = - analyze_sequence(sexp_cddar(obj), bc, i, e, params, fv, sv, d, tailp); - if (sexp_exceptionp(exn)) return exn; - /* set the result and pop off the local vars */ - emit(bc, i, OP_STACK_SET); - emit_word(bc, i, tmp1+1); - (*d) -= (tmp1-1); - for ( ; tmp1>0; tmp1--) - emit(bc, i, OP_DROP); - } else -#endif - /* computed application */ - return analyze_app(obj, bc, i, e, params, fv, sv, d, tailp); - } else { - return sexp_compile_error("invalid operator", sexp_list1(sexp_car(obj))); - } - } else if (sexp_symbolp(obj)) { - analyze_var_ref(obj, bc, i, e, params, fv, sv, d); - } else { /* literal */ - emit_push(bc, i, obj); - (*d)++; - } - return SEXP_TRUE; +sexp analyze_lambda (sexp x, sexp env) { + sexp res, body; + /* XXXX verify syntax */ + res = sexp_alloc_type(lambda, SEXP_LAMBDA); + sexp_lambda_params(res) = sexp_cadr(x); + env = extend_env(env, sexp_flatten_dot(sexp_lambda_params(res)), res); + sexp_env_lambda(env) = res; + body = analyze_seq(sexp_cddr(x), env); + analyze_check_exception(body); + sexp_lambda_body(res) = body; + return res; } -sexp analyze_sequence (sexp ls, sexp *bc, sexp_uint_t *i, sexp e, - sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp) -{ - sexp exn; - for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) { - if (sexp_pairp(sexp_cdr(ls))) { - exn = analyze(sexp_car(ls), bc, i, e, params, fv, sv, d, 0); - if (sexp_exceptionp(exn)) - return exn; - emit(bc, i, OP_DROP); - (*d)--; - } else { - analyze(sexp_car(ls), bc, i, e, params, fv, sv, d, tailp); - } +sexp analyze_seq (sexp ls, sexp env) { + sexp res, tmp; + if (sexp_nullp(ls)) + res = SEXP_UNDEF; + else if (sexp_nullp(sexp_cdr(ls))) + res = analyze(sexp_car(ls), env); + else { + res = sexp_alloc_type(seq, SEXP_SEQ); + tmp = analyze_app(ls, env); + analyze_check_exception(tmp); + sexp_seq_ls(res) = tmp; } - return SEXP_TRUE; + return res; } -sexp analyze_opcode (sexp op, sexp obj, sexp *bc, sexp_uint_t *i, sexp e, - sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp) -{ - sexp ls, exn; - int j, len = sexp_unbox_integer(sexp_length(sexp_cdr(obj))); +sexp analyze_if (sexp x, sexp env) { + sexp test, pass, fail; + analyze_bind(test, sexp_car(x), env); + analyze_bind(pass, sexp_cadr(x), env); + analyze_bind(fail, sexp_pairp(sexp_cddr(x))?sexp_caddr(x):SEXP_UNDEF, env); + return sexp_make_cnd(test, pass, fail); +} - /* verify parameters */ - if (len < sexp_opcode_num_args(op)) { - return sexp_compile_error("not enough arguments", sexp_list1(obj)); - } else if (len > sexp_opcode_num_args(op)) { - if (! sexp_opcode_variadic_p(op)) - return sexp_compile_error("too many arguments", sexp_list1(obj)); - } else if (sexp_opcode_variadic_p(op) && sexp_opcode_data(op)) { - emit(bc, i, OP_PARAMETER); - emit_word(bc, i, (sexp_uint_t) sexp_opcode_data(op)); +sexp analyze_app (sexp x, sexp env) { + sexp res=SEXP_NULL, tmp; + for ( ; sexp_pairp(x); x=sexp_cdr(x)) { + analyze_bind(tmp, sexp_car(x), env); + sexp_push(res, tmp); + } + return sexp_nreverse(res); +} + +sexp analyze_define (sexp x, sexp env) { + sexp ref, name, value; + name = (sexp_pairp(sexp_cadr(x)) ? sexp_caadr(x) : sexp_cadr(x)); + if (sexp_lambdap(sexp_env_lambda(env))) + sexp_push(sexp_lambda_locals(sexp_env_lambda(env)), name); + if (sexp_pairp(sexp_cadr(x))) + value = analyze_lambda(sexp_cons(SEXP_UNDEF, + sexp_cons(sexp_cdadr(x), sexp_cddr(x))), + env); + else + value = analyze(sexp_caddr(x), env); + analyze_check_exception(value); + ref = analyze_var_ref(name, env); + analyze_check_exception(ref); + env_cell_create(env, name, SEXP_DEF); + return sexp_make_set(ref, value); +} + +sexp analyze_var_ref (sexp x, sexp env) { + sexp cell = env_cell_create(env, x, SEXP_UNDEF); + return sexp_make_ref(x, sexp_cdr(cell)); +} + +sexp analyze_set (sexp x, sexp env) { + sexp ref, value; + ref = analyze_var_ref(sexp_cadr(x), env); + if (sexp_lambdap(sexp_ref_loc(ref))) + sexp_insert(sexp_lambda_sv(sexp_ref_loc(ref)), sexp_ref_name(ref)); + analyze_check_exception(ref); + analyze_bind(value, sexp_caddr(x), env); + return sexp_make_set(ref, value); +} + +sexp_uint_t sexp_context_make_label (sexp context) { + sexp_uint_t label = sexp_context_pos(context); + sexp_context_pos(context) += sizeof(sexp_uint_t); + return label; +} + +void sexp_context_patch_label (sexp context, sexp_uint_t label) { + sexp bc = sexp_context_bc(context); + ((sexp_uint_t*) sexp_bytecode_data(bc))[label] + = sexp_context_pos(context)-label; +} + +static sexp finalize_bytecode (sexp context) { + emit(OP_RET, context); + shrink_bcode(context, sexp_context_pos(context)); + return sexp_context_bc(context); +} + +void compile_one (sexp x, sexp context) { + if (sexp_pointerp(x)) { + switch (sexp_pointer_tag(x)) { + case SEXP_PAIR: + compile_app(x, context); + break; + case SEXP_LAMBDA: + compile_lambda(x, context); + break; + case SEXP_CND: + compile_cnd(x, context); + break; + case SEXP_REF: + compile_ref(x, context, 1); + break; + case SEXP_SET: + compile_set(x, context); + break; + case SEXP_SEQ: + compile_seq(sexp_seq_ls(x), context); + break; + case SEXP_LIT: + compile_lit(sexp_lit_value(x), context); + break; + default: + compile_lit(x, context); + } + } else { + compile_lit(x, context); + } +} + +void compile_lit (sexp value, sexp context) { + emit_push(value, context); +} + +void compile_seq (sexp app, sexp context) { + sexp head=app, tail=sexp_cdr(app); + for ( ; sexp_pairp(tail); head=tail, tail=sexp_cdr(tail)) { + compile_one(sexp_car(head), context); + emit(OP_DROP, context); + sexp_context_depth(context)--; + } + compile_one(sexp_car(head), context); +} + +void compile_cnd (sexp cnd, sexp context) { + sexp_uint_t label1, label2; + compile_one(sexp_cnd_test(cnd), context); + emit(OP_JUMP_UNLESS, context); + sexp_context_depth(context)--; + label1 = sexp_context_make_label(context); + compile_one(sexp_cnd_pass(cnd), context); + emit(OP_JUMP, context); + sexp_context_depth(context)--; + label2 = sexp_context_make_label(context); + sexp_context_patch_label(context, label1); + compile_one(sexp_cnd_fail(cnd), context); + sexp_context_patch_label(context, label2); +} + +void compile_ref (sexp ref, sexp context, int unboxp) { + sexp lam; + if (! sexp_lambdap(sexp_ref_loc(ref))) { + /* global ref */ + emit_push(ref, context); + emit(OP_CDR, context); + } else { + lam = sexp_context_lambda(context); + compile_non_global_ref(sexp_ref_name(ref), sexp_ref_loc(ref), lam, + sexp_lambda_fv(lam), context, unboxp); + } +} + +void compile_non_global_ref (sexp name, sexp loc, sexp lambda, sexp fv, + sexp context, int unboxp) { + sexp ls; + sexp_uint_t i; + if (loc == lambda) { + /* local ref */ + emit(OP_LOCAL_REF, context); + emit_word(sexp_list_index(sexp_lambda_params(lambda), name), context); + } else { + /* closure ref */ + for (i=0; sexp_pairp(fv); ls=sexp_cdr(fv), i++) + if (name == sexp_car(fv) && loc == sexp_cdr(fv)) + break; + emit(OP_CLOSURE_REF, context); + emit_word(i, context); + } + if (unboxp && (sexp_list_index(sexp_lambda_sv(loc), name) >= 0)) + emit(OP_CDR, context); + sexp_context_depth(context)++; +} + +void compile_set (sexp set, sexp context) { + sexp ref = sexp_set_var(set); + /* compile the value */ + compile_one(sexp_set_value(set), context); + if (! sexp_lambdap(sexp_ref_loc(ref))) { + /* global vars are set directly */ + emit_push(ref, context); + } else { + /* stack or closure mutable vars are boxed */ + compile_ref(ref, context, 0); + } + emit(OP_SET_CDR, context); + sexp_context_depth(context)--; +} + +void compile_app (sexp app, sexp context) { + if (sexp_opcodep(sexp_car(app))) + compile_opcode_app(app, context); + else + compile_general_app(app, context); +} + +void compile_opcode_app (sexp app, sexp context) { + sexp ls, op = sexp_car(app); + sexp_sint_t i, num_args = sexp_unbox_integer(sexp_length(sexp_cdr(app))); + + /* maybe push the default for an optional argument */ + if ((num_args < sexp_opcode_num_args(op)) + && sexp_opcode_variadic_p(op) && sexp_opcode_data(op)) { + emit(OP_PARAMETER, context); + emit_word((sexp_uint_t)sexp_opcode_data(op), context); if (! sexp_opcode_opt_param_p(op)) { - emit(bc, i, OP_CALL); - emit_word(bc, i, (sexp_uint_t) sexp_make_integer(0)); + emit(OP_CALL, context); + emit_word((sexp_uint_t)sexp_make_integer(0), context); } - (*d)++; - len++; + sexp_context_depth(context)++; + num_args++; } - /* push arguments */ - for (ls=sexp_reverse(sexp_cdr(obj)); sexp_pairp(ls); ls=sexp_cdr(ls)) { - exn = analyze(sexp_car(ls), bc, i, e, params, fv, sv, d, 0); - if (sexp_exceptionp(exn)) return exn; - } + /* push the arguments onto the stack */ + ls = (sexp_opcode_inverse(op) + && ! sexp_opcode_class(op) == OPC_ARITHMETIC_INV) + ? sexp_cdr(app) : sexp_reverse(sexp_cdr(app)); + for ( ; sexp_pairp(ls); ls = sexp_cdr(ls)) + compile_one(sexp_car(ls), context); - /* emit operator */ + /* emit the actual operator call */ if (sexp_opcode_class(op) == OPC_ARITHMETIC_INV) { - emit(bc, i, (len == 1) ? sexp_opcode_inverse(op) : sexp_opcode_code(op)); + emit((num_args == 1) ? sexp_opcode_inverse(op) + : sexp_opcode_code(op), context); } else { if (sexp_opcode_class(op) == OPC_FOREIGN) - emit_push(bc, i, sexp_opcode_data(op)); - else if ((len > 2) && sexp_opcode_class(op) == OPC_ARITHMETIC_CMP) { - emit(bc, i, OP_STACK_REF); - emit_word(bc, i, 2); - } - emit(bc, i, sexp_opcode_inverse(op) ? sexp_opcode_inverse(op) - : sexp_opcode_code(op)); + /* push the funtion pointer for foreign calls */ + emit_push(sexp_opcode_data(op), context); + emit(sexp_opcode_inverse(op) ? sexp_opcode_inverse(op) + : sexp_opcode_code(op), + context); } /* emit optional folding of operator */ - if (len > 2) { + if (num_args > 2) { if (sexp_opcode_class(op) == OPC_ARITHMETIC || sexp_opcode_class(op) == OPC_ARITHMETIC_INV) { - for (j=len-2; j>0; j--) - emit(bc, i, sexp_opcode_code(op)); + for (i=num_args-2; i>0; i--) + emit(sexp_opcode_code(op), context); } else if (sexp_opcode_class(op) == OPC_ARITHMETIC_CMP) { - for (j=len-2; j>0; j--) { - /* emit(bc, i, OP_JUMP_UNLESS); */ - emit(bc, i, sexp_opcode_code(op)); - } + /* XXXX handle folding of comparisons */ } } if (sexp_opcode_class(op) == OPC_PARAMETER) - emit_word(bc, i, (sexp_uint_t) sexp_opcode_data(op)); + emit_word((sexp_uint_t)sexp_opcode_data(op), context); - (*d) -= (len-1); - - return SEXP_TRUE; + sexp_context_depth(context) -= (num_args-1); } -void analyze_var_ref (sexp obj, sexp *bc, sexp_uint_t *i, sexp e, - sexp params, sexp fv, sexp sv, sexp_uint_t *d) { - int tmp; - sexp cell; - if ((tmp = sexp_list_index(params, obj)) >= 0) { - cell = env_cell(e, obj); - emit(bc, i, OP_STACK_REF); - emit_word(bc, i, *d - sexp_unbox_integer(sexp_cdr(cell))); - } else if ((tmp = sexp_list_index(fv, obj)) >= 0) { - emit(bc, i, OP_CLOSURE_REF); - emit_word(bc, i, (sexp_uint_t) sexp_make_integer(tmp)); - } else { - cell = env_cell_create(e, obj); - emit_push(bc, i, cell); - emit(bc, i, OP_CDR); - } - (*d)++; - if (sexp_list_index(sv, obj) >= 0) { - emit(bc, i, OP_CAR); - } -} - -sexp analyze_app (sexp obj, sexp *bc, sexp_uint_t *i, sexp e, - sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp) { - sexp o1, exn; - sexp_uint_t len = sexp_unbox_integer(sexp_length(sexp_cdr(obj))); +void compile_general_app (sexp app, sexp context) { + sexp ls; + sexp_uint_t len = sexp_unbox_integer(sexp_length(sexp_cdr(app))); /* push the arguments onto the stack */ - for (o1 = sexp_reverse(sexp_cdr(obj)); sexp_pairp(o1); o1 = sexp_cdr(o1)) { - exn = analyze(sexp_car(o1), bc, i, e, params, fv, sv, d, 0); - if (sexp_exceptionp(exn)) return exn; - } + for (ls = sexp_reverse(sexp_cdr(app)); sexp_pairp(ls); ls = sexp_cdr(ls)) + compile_one(sexp_car(ls), context); /* push the operator onto the stack */ - exn = analyze(sexp_car(obj), bc, i, e, params, fv, sv, d, 0); - if (sexp_exceptionp(exn)) return exn; + compile_one(sexp_car(app), context); /* maybe overwrite the current frame */ - if (tailp) { - emit(bc, i, OP_TAIL_CALL); - emit_word(bc, i, (sexp_uint_t) sexp_make_integer(sexp_unbox_integer(sexp_length(params))+(*d)+3)); - emit_word(bc, i, (sexp_uint_t) sexp_make_integer(len)); + if (sexp_context_tailp(context)) { + emit(OP_TAIL_CALL, context); + emit_word(sexp_context_depth(context), context); + emit_word((sexp_uint_t)sexp_make_integer(len), context); } else { /* normal call */ - emit(bc, i, OP_CALL); - emit_word(bc, i, (sexp_uint_t) sexp_make_integer(len)); + emit(OP_CALL, context); + emit_word((sexp_uint_t)sexp_make_integer(len), context); } - (*d) -= (len); - return SEXP_TRUE; + sexp_context_depth(context) -= len; } -sexp free_vars (sexp e, sexp formals, sexp obj, sexp fv) { - sexp o1; - if (sexp_symbolp(obj)) { - if (env_global_p(e, obj) - || (sexp_list_index(formals, obj) >= 0) - || (sexp_list_index(fv, obj) >= 0)) - return fv; - else - return sexp_cons(obj, fv); - } else if (sexp_pairp(obj)) { - if (sexp_symbolp(sexp_car(obj))) { - if ((o1 = env_cell(e, sexp_car(obj))) - && sexp_corep(o1) - && (sexp_core_code(sexp_cdr(o1)) == CORE_LAMBDA)) { - return free_vars(e, sexp_cadr(obj), sexp_caddr(obj), fv); - } - } - while (sexp_pairp(obj)) { - fv = free_vars(e, formals, sexp_car(obj), fv); - obj = sexp_cdr(obj); - } - return fv; - } else { - return fv; - } -} - -sexp set_vars (sexp e, sexp formals, sexp obj, sexp sv) { - sexp cell; - int code; - if (sexp_nullp(formals)) - return sv; - if (sexp_pairp(obj)) { - if (sexp_symbolp(sexp_car(obj))) { - if ((cell = env_cell(e, sexp_car(obj))) && sexp_corep(sexp_cdr(cell))) { - code = sexp_core_code(sexp_cdr(cell)); - if (code == CORE_LAMBDA) { - formals = sexp_lset_diff(formals, sexp_cadr(obj)); - return set_vars(e, formals, sexp_caddr(obj), sv); - } else if ((code == CORE_SET || code == CORE_DEFINE) - && (sexp_list_index(formals, sexp_cadr(obj)) >= 0) - && ! (sexp_list_index(sv, sexp_cadr(obj)) >= 0)) { - sv = sexp_cons(sexp_cadr(obj), sv); - return set_vars(e, formals, sexp_caddr(obj), sv); - } - } - } - while (sexp_pairp(obj)) { - sv = set_vars(e, formals, sexp_car(obj), sv); - obj = sexp_cdr(obj); - } - } - return sv; -} - -sexp analyze_lambda (sexp name, sexp formals, sexp body, - sexp *bc, sexp_uint_t *i, sexp e, - sexp params, sexp fv, sexp sv, sexp_uint_t *d, - int tailp) { - sexp obj, ls, flat_formals, fv2, e2; - int k; - flat_formals = sexp_flatten_dot(formals); - fv2 = free_vars(e, flat_formals, body, SEXP_NULL); - e2 = extend_env(e, flat_formals, -4); - /* compile the body with respect to the new params */ - obj = compile(flat_formals, body, e2, fv2, sv, 0); - if (sexp_exceptionp(obj)) return obj; - if (sexp_nullp(fv2)) { - /* no variables to close over, fixed procedure */ - emit_push(bc, i, - sexp_make_procedure(sexp_make_integer((sexp_listp(formals) - ? 0 : 1)), - sexp_length(formals), - obj, - sexp_make_vector(sexp_make_integer(0), - SEXP_UNDEF))); - (*d)++; +void compile_lambda (sexp lambda, sexp context) { + sexp fv, ctx, flags, bc, len, ref, vec, prev_lambda, prev_fv; + sexp_uint_t k; + prev_lambda = sexp_context_lambda(context); + prev_fv = sexp_lambda_fv(prev_lambda); + fv = sexp_lambda_fv(lambda); + ctx = sexp_new_context(sexp_context_stack(context)); + sexp_context_lambda(ctx) = lambda; + compile_one(sexp_lambda_body(lambda), ctx); + flags = sexp_make_integer(sexp_listp(sexp_lambda_params(lambda)) ? 0 : 1); + len = sexp_length(sexp_lambda_params(lambda)); + bc = finalize_bytecode(ctx); + if (sexp_nullp(fv)) { + vec = sexp_make_vector(sexp_make_integer(0), SEXP_UNDEF); + compile_lit(sexp_make_procedure(flags, len, bc, vec), context); } else { /* push the closed vars */ - emit_push(bc, i, SEXP_UNDEF); - emit_push(bc, i, sexp_length(fv2)); - emit(bc, i, OP_MAKE_VECTOR); - (*d)++; - for (ls=fv2, k=0; sexp_pairp(ls); ls=sexp_cdr(ls), k++) { - analyze_var_ref(sexp_car(ls), bc, i, e, params, fv, SEXP_NULL, d); - emit_push(bc, i, sexp_make_integer(k)); - emit(bc, i, OP_STACK_REF); - emit_word(bc, i, 3); - emit(bc, i, OP_VECTOR_SET); - emit(bc, i, OP_DROP); - (*d)--; + emit_push(SEXP_UNDEF, context); + emit_push(len, context); + emit(OP_MAKE_VECTOR, context); + sexp_context_depth(context)--; + for (k=0; sexp_pairp(fv); fv=sexp_cdr(fv), k++) { + ref = sexp_car(fv); + compile_non_global_ref(sexp_ref_name(ref), sexp_ref_loc(ref), + prev_lambda, prev_fv, context, 1); + emit_push(sexp_make_integer(k), context); + emit(OP_LOCAL_REF, context); + emit_word(3, context); + emit(OP_VECTOR_SET, context); + emit(OP_DROP, context); + sexp_context_depth(context)--; } /* push the additional procedure info and make the closure */ - emit_push(bc, i, obj); - emit_push(bc, i, sexp_length(formals)); - emit_push(bc, i, sexp_make_integer(sexp_listp(formals) ? 0 : 1)); - emit(bc, i, OP_MAKE_PROCEDURE); + emit_push(bc, context); + emit_push(len, context); + emit_push(flags, context); + emit(OP_MAKE_PROCEDURE, context); } - return SEXP_TRUE; } +/* sexp xanalyze(sexp obj, sexp *bc, sexp_uint_t *i, sexp e, */ +/* sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp) { */ +/* int tmp1, tmp2; */ +/* sexp o1, o2, e2, cell, exn; */ + +/* loop: */ +/* if (sexp_pairp(obj)) { */ +/* if (sexp_symbolp(sexp_car(obj))) { */ +/* o1 = env_cell(e, sexp_car(obj)); */ +/* if (! o1) { */ +/* return analyze_app(obj, bc, i, e, params, fv, sv, d, tailp); */ +/* } */ +/* o1 = sexp_cdr(o1); */ +/* if (sexp_corep(o1)) { */ +/* switch (sexp_core_code(o1)) { */ +/* case CORE_LAMBDA: */ +/* return analyze_lambda(SEXP_FALSE, sexp_cadr(obj), sexp_cddr(obj), */ +/* bc, i, e, params, fv, sv, d, tailp); */ +/* case CORE_DEFINE_SYNTAX: */ +/* o2 = eval(sexp_caddr(obj), e); */ +/* if (sexp_exceptionp(o2)) return o2; */ +/* env_define(e, sexp_cadr(obj), sexp_make_macro(o2, e)); */ +/* emit_push(bc, i, SEXP_UNDEF); */ +/* (*d)++; */ +/* break; */ +/* case CORE_DEFINE: */ +/* if ((sexp_core_code(o1) == CORE_DEFINE) */ +/* && sexp_pairp(sexp_cadr(obj))) { */ +/* o2 = sexp_car(sexp_cadr(obj)); */ +/* exn = analyze_lambda(sexp_caadr(obj), sexp_cdadr(obj), */ +/* sexp_cddr(obj), */ +/* bc, i, e, params, fv, sv, d, 0); */ +/* } else { */ +/* o2 = sexp_cadr(obj); */ +/* exn = analyze(sexp_caddr(obj), bc, i, e, params, fv, sv, d, 0); */ +/* } */ +/* if (sexp_exceptionp(exn)) return exn; */ +/* if (sexp_env_global_p(e)) { */ +/* cell = env_cell_create(e, o2); */ +/* emit_push(bc, i, cell); */ +/* emit(bc, i, OP_SET_CDR); */ +/* } else { */ +/* cell = env_cell(e, o2); */ +/* if (! cell || ! sexp_integerp(sexp_cdr(cell))) { */ +/* return sexp_compile_error("define in bad position", */ +/* sexp_list1(obj)); */ +/* } else { */ +/* emit(bc, i, OP_STACK_SET); */ +/* emit_word(bc, i, (*d)+1-sexp_unbox_integer(sexp_cdr(cell))); */ +/* } */ +/* } */ +/* (*d)++; */ +/* break; */ +/* case CORE_SET: */ +/* exn = analyze(sexp_caddr(obj), bc, i, e, params, fv, sv, d, 0); */ +/* if (sexp_exceptionp(exn)) return exn; */ +/* if (sexp_list_index(sv, sexp_cadr(obj)) >= 0) { */ +/* analyze_var_ref(sexp_cadr(obj), bc, i, e, params, fv, SEXP_NULL, d); */ +/* emit(bc, i, OP_SET_CAR); */ +/* (*d)--; */ +/* } else { */ +/* cell = env_cell_create(e, sexp_cadr(obj)); */ +/* emit_push(bc, i, cell); */ +/* emit(bc, i, OP_SET_CDR); */ +/* } */ +/* break; */ +/* case CORE_BEGIN: */ +/* return */ +/* analyze_sequence(sexp_cdr(obj), bc, i, e, params, fv, sv, d, tailp); */ +/* case CORE_IF: */ +/* exn = analyze(sexp_cadr(obj), bc, i, e, params, fv, sv, d, 0); */ +/* if (sexp_exceptionp(exn)) return exn; */ +/* emit(bc, i, OP_JUMP_UNLESS); /\* jumps if test fails *\/ */ +/* (*d)--; */ +/* tmp1 = *i; */ +/* emit(bc, i, 0); */ +/* exn = analyze(sexp_caddr(obj), bc, i, e, params, fv, sv, d, tailp); */ +/* if (sexp_exceptionp(exn)) return exn; */ +/* emit(bc, i, OP_JUMP); */ +/* (*d)--; */ +/* tmp2 = *i; */ +/* emit(bc, i, 0); */ +/* ((signed char*) sexp_bytecode_data(*bc))[tmp1] = (*i)-tmp1; */ +/* if (sexp_pairp(sexp_cdddr(obj))) { */ +/* exn = analyze(sexp_cadddr(obj), bc, i, e, params, fv, sv, d, tailp); */ +/* if (sexp_exceptionp(exn)) return exn; */ +/* } else { */ +/* emit_push(bc, i, SEXP_UNDEF); */ +/* (*d)++; */ +/* } */ +/* ((signed char*) sexp_bytecode_data(*bc))[tmp2] = (*i)-tmp2; */ +/* break; */ +/* case CORE_QUOTE: */ +/* emit_push(bc, i, sexp_cadr(obj)); */ +/* (*d)++; */ +/* break; */ +/* default: */ +/* return sexp_compile_error("unknown core form", sexp_list1(o1)); */ +/* } */ +/* } else if (sexp_opcodep(o1)) { */ +/* return analyze_opcode(o1, obj, bc, i, e, params, fv, sv, d, tailp); */ +/* } else if (sexp_macrop(o1)) { */ +/* obj = sexp_expand_macro(o1, obj, e); */ +/* if (sexp_exceptionp(obj)) return obj; */ +/* goto loop; */ +/* } else { */ +/* /\* general procedure call *\/ */ +/* return analyze_app(obj, bc, i, e, params, fv, sv, d, tailp); */ +/* } */ +/* } else if (sexp_pairp(sexp_car(obj))) { */ +/* #if USE_FAST_LET */ +/* o2 = env_cell(e, sexp_caar(obj)); */ +/* if (o2 */ +/* && sexp_corep(sexp_cdr(o2)) */ +/* && (sexp_core_code(o2) == CORE_LAMBDA) */ +/* && sexp_listp(sexp_cadr(sexp_car(obj)))) { */ +/* /\* let *\/ */ +/* tmp1 = sexp_unbox_integer(sexp_length(sexp_cadar(obj))); */ +/* /\* push params as local stack variables *\/ */ +/* for (o2=sexp_reverse(sexp_cdr(obj)); sexp_pairp(o2); o2=sexp_cdr(o2)) { */ +/* exn = analyze(sexp_car(o2), bc, i, e, params, fv, sv, d, 0); */ +/* if (sexp_exceptionp(exn)) return exn; */ +/* } */ +/* /\* analyze the body in a new local env *\/ */ +/* e2 = extend_env(e, sexp_cadar(obj), (*d)+(tmp1-1)); */ +/* params = sexp_append(sexp_cadar(obj), params); */ +/* exn = */ +/* analyze_sequence(sexp_cddar(obj), bc, i, e, params, fv, sv, d, tailp); */ +/* if (sexp_exceptionp(exn)) return exn; */ +/* /\* set the result and pop off the local vars *\/ */ +/* emit(bc, i, OP_STACK_SET); */ +/* emit_word(bc, i, tmp1+1); */ +/* (*d) -= (tmp1-1); */ +/* for ( ; tmp1>0; tmp1--) */ +/* emit(bc, i, OP_DROP); */ +/* } else */ +/* #endif */ +/* /\* computed application *\/ */ +/* return analyze_app(obj, bc, i, e, params, fv, sv, d, tailp); */ +/* } else { */ +/* return sexp_compile_error("invalid operator", sexp_list1(sexp_car(obj))); */ +/* } */ +/* } else if (sexp_symbolp(obj)) { */ +/* analyze_var_ref(obj, bc, i, e, params, fv, sv, d); */ +/* } else { /\* literal *\/ */ +/* emit_push(bc, i, obj); */ +/* (*d)++; */ +/* } */ +/* return SEXP_TRUE; */ +/* } */ + +/* sexp analyze_sequence (sexp ls, sexp *bc, sexp_uint_t *i, sexp e, */ +/* sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp) */ +/* { */ +/* sexp exn; */ +/* for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) { */ +/* if (sexp_pairp(sexp_cdr(ls))) { */ +/* exn = analyze(sexp_car(ls), bc, i, e, params, fv, sv, d, 0); */ +/* if (sexp_exceptionp(exn)) */ +/* return exn; */ +/* emit(bc, i, OP_DROP); */ +/* (*d)--; */ +/* } else { */ +/* analyze(sexp_car(ls), bc, i, e, params, fv, sv, d, tailp); */ +/* } */ +/* } */ +/* return SEXP_TRUE; */ +/* } */ + +/* sexp analyze_opcode (sexp op, sexp obj, sexp *bc, sexp_uint_t *i, sexp e, */ +/* sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp) */ +/* { */ +/* sexp ls, exn; */ +/* int j, len = sexp_unbox_integer(sexp_length(sexp_cdr(obj))); */ + +/* /\* verify parameters *\/ */ +/* if (len < sexp_opcode_num_args(op)) { */ +/* return sexp_compile_error("not enough arguments", sexp_list1(obj)); */ +/* } else if (len > sexp_opcode_num_args(op)) { */ +/* if (! sexp_opcode_variadic_p(op)) */ +/* return sexp_compile_error("too many arguments", sexp_list1(obj)); */ +/* } else if (sexp_opcode_variadic_p(op) && sexp_opcode_data(op)) { */ +/* emit(bc, i, OP_PARAMETER); */ +/* emit_word(bc, i, (sexp_uint_t) sexp_opcode_data(op)); */ +/* if (! sexp_opcode_opt_param_p(op)) { */ +/* emit(bc, i, OP_CALL); */ +/* emit_word(bc, i, (sexp_uint_t) sexp_make_integer(0)); */ +/* } */ +/* (*d)++; */ +/* len++; */ +/* } */ + +/* /\* push arguments *\/ */ +/* for (ls=sexp_reverse(sexp_cdr(obj)); sexp_pairp(ls); ls=sexp_cdr(ls)) { */ +/* exn = analyze(sexp_car(ls), bc, i, e, params, fv, sv, d, 0); */ +/* if (sexp_exceptionp(exn)) return exn; */ +/* } */ + +/* /\* emit operator *\/ */ +/* if (sexp_opcode_class(op) == OPC_ARITHMETIC_INV) { */ +/* emit(bc, i, (len == 1) ? sexp_opcode_inverse(op) : sexp_opcode_code(op)); */ +/* } else { */ +/* if (sexp_opcode_class(op) == OPC_FOREIGN) */ +/* emit_push(bc, i, sexp_opcode_data(op)); */ +/* else if ((len > 2) && sexp_opcode_class(op) == OPC_ARITHMETIC_CMP) { */ +/* emit(bc, i, OP_STACK_REF); */ +/* emit_word(bc, i, 2); */ +/* } */ +/* emit(bc, i, sexp_opcode_inverse(op) ? sexp_opcode_inverse(op) */ +/* : sexp_opcode_code(op)); */ +/* } */ + +/* /\* emit optional folding of operator *\/ */ +/* if (len > 2) { */ +/* if (sexp_opcode_class(op) == OPC_ARITHMETIC */ +/* || sexp_opcode_class(op) == OPC_ARITHMETIC_INV) { */ +/* for (j=len-2; j>0; j--) */ +/* emit(bc, i, sexp_opcode_code(op)); */ +/* } else if (sexp_opcode_class(op) == OPC_ARITHMETIC_CMP) { */ +/* for (j=len-2; j>0; j--) { */ +/* /\* emit(bc, i, OP_JUMP_UNLESS); *\/ */ +/* emit(bc, i, sexp_opcode_code(op)); */ +/* } */ +/* } */ +/* } */ + +/* if (sexp_opcode_class(op) == OPC_PARAMETER) */ +/* emit_word(bc, i, (sexp_uint_t) sexp_opcode_data(op)); */ + +/* (*d) -= (len-1); */ + +/* return SEXP_TRUE; */ +/* } */ + +/* void analyze_var_ref (sexp obj, sexp *bc, sexp_uint_t *i, sexp e, */ +/* sexp params, sexp fv, sexp sv, sexp_uint_t *d) { */ +/* int tmp; */ +/* sexp cell; */ +/* if ((tmp = sexp_list_index(params, obj)) >= 0) { */ +/* cell = env_cell(e, obj); */ +/* emit(bc, i, OP_STACK_REF); */ +/* emit_word(bc, i, *d - sexp_unbox_integer(sexp_cdr(cell))); */ +/* } else if ((tmp = sexp_list_index(fv, obj)) >= 0) { */ +/* emit(bc, i, OP_CLOSURE_REF); */ +/* emit_word(bc, i, (sexp_uint_t) sexp_make_integer(tmp)); */ +/* } else { */ +/* cell = env_cell_create(e, obj); */ +/* emit_push(bc, i, cell); */ +/* emit(bc, i, OP_CDR); */ +/* } */ +/* (*d)++; */ +/* if (sexp_list_index(sv, obj) >= 0) { */ +/* emit(bc, i, OP_CAR); */ +/* } */ +/* } */ + +/* sexp analyze_app (sexp obj, sexp *bc, sexp_uint_t *i, sexp e, */ +/* sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp) { */ +/* sexp o1, exn; */ +/* sexp_uint_t len = sexp_unbox_integer(sexp_length(sexp_cdr(obj))); */ + +/* /\* push the arguments onto the stack *\/ */ +/* for (o1 = sexp_reverse(sexp_cdr(obj)); sexp_pairp(o1); o1 = sexp_cdr(o1)) { */ +/* exn = analyze(sexp_car(o1), bc, i, e, params, fv, sv, d, 0); */ +/* if (sexp_exceptionp(exn)) return exn; */ +/* } */ + +/* /\* push the operator onto the stack *\/ */ +/* exn = analyze(sexp_car(obj), bc, i, e, params, fv, sv, d, 0); */ +/* if (sexp_exceptionp(exn)) return exn; */ + +/* /\* maybe overwrite the current frame *\/ */ +/* if (tailp) { */ +/* emit(bc, i, OP_TAIL_CALL); */ +/* emit_word(bc, i, (sexp_uint_t) sexp_make_integer(sexp_unbox_integer(sexp_length(params))+(*d)+3)); */ +/* emit_word(bc, i, (sexp_uint_t) sexp_make_integer(len)); */ +/* } else { */ +/* /\* normal call *\/ */ +/* emit(bc, i, OP_CALL); */ +/* emit_word(bc, i, (sexp_uint_t) sexp_make_integer(len)); */ +/* } */ + +/* (*d) -= (len); */ +/* return SEXP_TRUE; */ +/* } */ + +/* sexp free_vars (sexp e, sexp formals, sexp obj, sexp fv) { */ +/* sexp o1; */ +/* if (sexp_symbolp(obj)) { */ +/* if (env_global_p(e, obj) */ +/* || (sexp_list_index(formals, obj) >= 0) */ +/* || (sexp_list_index(fv, obj) >= 0)) */ +/* return fv; */ +/* else */ +/* return sexp_cons(obj, fv); */ +/* } else if (sexp_pairp(obj)) { */ +/* if (sexp_symbolp(sexp_car(obj))) { */ +/* if ((o1 = env_cell(e, sexp_car(obj))) */ +/* && sexp_corep(o1) */ +/* && (sexp_core_code(sexp_cdr(o1)) == CORE_LAMBDA)) { */ +/* return free_vars(e, sexp_cadr(obj), sexp_caddr(obj), fv); */ +/* } */ +/* } */ +/* while (sexp_pairp(obj)) { */ +/* fv = free_vars(e, formals, sexp_car(obj), fv); */ +/* obj = sexp_cdr(obj); */ +/* } */ +/* return fv; */ +/* } else { */ +/* return fv; */ +/* } */ +/* } */ + +sexp insert_free_var (sexp x, sexp fv) { + sexp name=sexp_ref_name(x), loc=sexp_ref_loc(x), ls; + for (ls=fv; sexp_pairp(ls); ls=sexp_cdr(ls)) + if (name == sexp_caar(ls) && loc == sexp_cdar(ls)) + return fv; + return sexp_cons(x, fv); +} + +sexp union_free_vars (sexp fv1, sexp fv2) { + if (sexp_nullp(fv2)) + return fv1; + for ( ; sexp_pairp(fv1); fv1=sexp_cdr(fv1)) + fv2 = insert_free_var(sexp_car(fv1), fv2); + return fv2; +} + +sexp free_vars (sexp x, sexp fv) { + sexp fv1, fv2; + if (sexp_lambdap(x)) { + fv1 = free_vars(sexp_lambda_body(x), SEXP_NULL); + fv2 = sexp_lset_diff(fv1, sexp_flatten_dot(sexp_lambda_params(x))); + sexp_lambda_fv(x) = fv2; + fv = union_free_vars(fv2, fv); + } else if (sexp_pairp(x)) { + for ( ; sexp_pairp(x); x=sexp_cdr(x)) + fv = free_vars(sexp_car(x), fv); + } else if (sexp_cndp(x)) { + fv = free_vars(sexp_cnd_test(x), fv); + fv = free_vars(sexp_cnd_pass(x), fv); + fv = free_vars(sexp_cnd_fail(x), fv); + } else if (sexp_seqp(x)) { + for (x=sexp_seq_ls(x); sexp_pairp(x); x=sexp_cdr(x)) + fv = free_vars(sexp_car(x), fv); + } else if (sexp_setp(x)) { + fv = free_vars(sexp_set_value(x), fv); + fv = free_vars(sexp_set_var(x), fv); + } else if (sexp_refp(x) && sexp_lambdap(sexp_ref_loc(x))) { + fv = insert_free_var(x, fv); + } + return fv; +} + +/* sexp set_vars (sexp e, sexp formals, sexp obj, sexp sv) { */ +/* sexp cell; */ +/* int code; */ +/* if (sexp_nullp(formals)) */ +/* return sv; */ +/* if (sexp_pairp(obj)) { */ +/* if (sexp_symbolp(sexp_car(obj))) { */ +/* if ((cell = env_cell(e, sexp_car(obj))) && sexp_corep(sexp_cdr(cell))) { */ +/* code = sexp_core_code(sexp_cdr(cell)); */ +/* if (code == CORE_LAMBDA) { */ +/* formals = sexp_lset_diff(formals, sexp_cadr(obj)); */ +/* return set_vars(e, formals, sexp_caddr(obj), sv); */ +/* } else if ((code == CORE_SET || code == CORE_DEFINE) */ +/* && (sexp_list_index(formals, sexp_cadr(obj)) >= 0) */ +/* && ! (sexp_list_index(sv, sexp_cadr(obj)) >= 0)) { */ +/* sv = sexp_cons(sexp_cadr(obj), sv); */ +/* return set_vars(e, formals, sexp_caddr(obj), sv); */ +/* } */ +/* } */ +/* } */ +/* while (sexp_pairp(obj)) { */ +/* sv = set_vars(e, formals, sexp_car(obj), sv); */ +/* obj = sexp_cdr(obj); */ +/* } */ +/* } */ +/* return sv; */ +/* } */ + +/* sexp analyze_lambda (sexp name, sexp formals, sexp body, */ +/* sexp *bc, sexp_uint_t *i, sexp e, */ +/* sexp params, sexp fv, sexp sv, sexp_uint_t *d, */ +/* int tailp) { */ +/* sexp obj, ls, flat_formals, fv2, e2; */ +/* int k; */ +/* flat_formals = sexp_flatten_dot(formals); */ +/* fv2 = free_vars(e, flat_formals, body, SEXP_NULL); */ +/* e2 = extend_env(e, flat_formals, -4); */ +/* /\* compile the body with respect to the new params *\/ */ +/* obj = compile(flat_formals, body, e2, fv2, sv, 0); */ +/* if (sexp_exceptionp(obj)) return obj; */ +/* if (sexp_nullp(fv2)) { */ +/* /\* no variables to close over, fixed procedure *\/ */ +/* emit_push(bc, i, */ +/* sexp_make_procedure(sexp_make_integer((sexp_listp(formals) */ +/* ? 0 : 1)), */ +/* sexp_length(formals), */ +/* obj, */ +/* sexp_make_vector(sexp_make_integer(0), */ +/* SEXP_UNDEF))); */ +/* (*d)++; */ +/* } else { */ +/* /\* push the closed vars *\/ */ +/* emit_push(bc, i, SEXP_UNDEF); */ +/* emit_push(bc, i, sexp_length(fv2)); */ +/* emit(bc, i, OP_MAKE_VECTOR); */ +/* (*d)++; */ +/* for (ls=fv2, k=0; sexp_pairp(ls); ls=sexp_cdr(ls), k++) { */ +/* analyze_var_ref(sexp_car(ls), bc, i, e, params, fv, SEXP_NULL, d); */ +/* emit_push(bc, i, sexp_make_integer(k)); */ +/* emit(bc, i, OP_STACK_REF); */ +/* emit_word(bc, i, 3); */ +/* emit(bc, i, OP_VECTOR_SET); */ +/* emit(bc, i, OP_DROP); */ +/* (*d)--; */ +/* } */ +/* /\* push the additional procedure info and make the closure *\/ */ +/* emit_push(bc, i, obj); */ +/* emit_push(bc, i, sexp_length(formals)); */ +/* emit_push(bc, i, sexp_make_integer(sexp_listp(formals) ? 0 : 1)); */ +/* emit(bc, i, OP_MAKE_PROCEDURE); */ +/* } */ +/* return SEXP_TRUE; */ +/* } */ + sexp make_param_list(sexp_uint_t i) { sexp res = SEXP_NULL; char sym[2]="a"; @@ -656,92 +1097,93 @@ sexp make_param_list(sexp_uint_t i) { } sexp make_opcode_procedure(sexp op, sexp_uint_t i, sexp e) { - sexp bc, params, res; - sexp_uint_t pos=0, d=0; - if (i == sexp_opcode_num_args(op) && sexp_opcode_proc(op)) - return sexp_opcode_proc(op); - bc = sexp_alloc_tagged(sexp_sizeof(bytecode)+INIT_BCODE_SIZE, SEXP_BYTECODE); - params = make_param_list(i); - e = extend_env(e, params, -4); - sexp_bytecode_length(bc) = INIT_BCODE_SIZE; - analyze_opcode(op, sexp_cons(op, params), &bc, &pos, e, params, - SEXP_NULL, SEXP_NULL, &d, 0); - emit(&bc, &pos, OP_RET); - shrink_bcode(&bc, pos); - /* disasm(bc); */ - res = sexp_make_procedure(sexp_make_integer(0), sexp_make_integer(i), bc, SEXP_UNDEF); - if (i == sexp_opcode_num_args(op)) - sexp_opcode_proc(op) = res; - return res; +/* sexp bc, params, res; */ +/* sexp_uint_t pos=0, d=0; */ +/* if (i == sexp_opcode_num_args(op) && sexp_opcode_proc(op)) */ +/* return sexp_opcode_proc(op); */ +/* bc = sexp_alloc_tagged(sexp_sizeof(bytecode)+INIT_BCODE_SIZE, SEXP_BYTECODE); */ +/* params = make_param_list(i); */ +/* e = extend_env(e, params, SEXP_UNDEF); */ +/* sexp_bytecode_length(bc) = INIT_BCODE_SIZE; */ +/* analyze_opcode(op, sexp_cons(op, params), &bc, &pos, e, params, */ +/* SEXP_NULL, SEXP_NULL, &d, 0); */ +/* emit(&bc, &pos, OP_RET); */ +/* shrink_bcode(&bc, pos); */ +/* /\* disasm(bc); *\/ */ +/* res = sexp_make_procedure(sexp_make_integer(0), sexp_make_integer(i), bc, SEXP_UNDEF); */ +/* if (i == sexp_opcode_num_args(op)) */ +/* sexp_opcode_proc(op) = res; */ +/* return res; */ + return SEXP_UNDEF; } -sexp compile(sexp params, sexp obj, sexp e, sexp fv, sexp sv, int done_p) { - sexp_uint_t i=0, j=0, d=0, define_ok=1, core; - sexp bc = sexp_alloc_tagged(sexp_sizeof(bytecode)+INIT_BCODE_SIZE, - SEXP_BYTECODE); - sexp sv2 = set_vars(e, params, obj, SEXP_NULL), internals=SEXP_NULL, ls; - sexp_bytecode_length(bc) = INIT_BCODE_SIZE; - /* box mutable vars */ - for (ls=params, j=0; sexp_pairp(ls); ls=sexp_cdr(ls), j++) { - if (sexp_list_index(sv2, sexp_car(ls)) >= 0) { - emit_push(&bc, &i, SEXP_NULL); - emit(&bc, &i, OP_STACK_REF); - emit_word(&bc, &i, j+5); - emit(&bc, &i, OP_CONS); - emit(&bc, &i, OP_STACK_SET); - emit_word(&bc, &i, j+5); - emit(&bc, &i, OP_DROP); - } - } - sv = sexp_append(sv2, sv); - /* determine internal defines */ - if (sexp_env_parent(e)) { - for (ls=SEXP_NULL; sexp_pairp(obj); obj=sexp_cdr(obj)) { - core = (sexp_pairp(sexp_car(obj)) && sexp_symbolp(sexp_caar(obj)) - ? core_code(e, sexp_caar(obj)) : 0); - if (core == CORE_BEGIN) { - obj = sexp_cons(sexp_car(obj), - sexp_append(sexp_cdar(obj), sexp_cdr(obj))); - } else { - if (core == CORE_DEFINE) { - if (! define_ok) - return sexp_compile_error("definition in non-definition context", - sexp_list1(obj)); - internals = sexp_cons(sexp_pairp(sexp_cadar(obj)) - ? sexp_car(sexp_cadar(obj)) : sexp_cadar(obj), - internals); - } else { - define_ok = 0; - } - ls = sexp_cons(sexp_car(obj), ls); - } - } - obj = sexp_reverse(ls); - j = sexp_unbox_integer(sexp_length(internals)); - if (sexp_pairp(internals)) { - e = extend_env(e, internals, d+j); - /* XXXX params extended, need to recompute set-vars */ - params = sexp_append(internals, params); - for (ls=internals; sexp_pairp(ls); ls=sexp_cdr(ls)) - emit_push(&bc, &i, SEXP_UNDEF); - d+=j; - } - } - /* analyze body sequence */ - analyze_sequence(obj, &bc, &i, e, params, fv, sv, &d, - (! done_p) && (! sexp_pairp(internals))); - if (sexp_pairp(internals)) { - emit(&bc, &i, OP_STACK_SET); - emit_word(&bc, &i, j+1); - for ( ; j>0; j--) - emit(&bc, &i, OP_DROP); - } - emit(&bc, &i, done_p ? OP_DONE : OP_RET); - shrink_bcode(&bc, i); - print_bytecode(bc); - disasm(bc); - return bc; -} +/* sexp compile(sexp params, sexp obj, sexp e, sexp fv, sexp sv, int done_p) { */ +/* sexp_uint_t i=0, j=0, d=0, define_ok=1, core; */ +/* sexp bc = sexp_alloc_tagged(sexp_sizeof(bytecode)+INIT_BCODE_SIZE, */ +/* SEXP_BYTECODE); */ +/* sexp sv2 = set_vars(e, params, obj, SEXP_NULL), internals=SEXP_NULL, ls; */ +/* sexp_bytecode_length(bc) = INIT_BCODE_SIZE; */ +/* /\* box mutable vars *\/ */ +/* for (ls=params, j=0; sexp_pairp(ls); ls=sexp_cdr(ls), j++) { */ +/* if (sexp_list_index(sv2, sexp_car(ls)) >= 0) { */ +/* emit_push(&bc, &i, SEXP_NULL); */ +/* emit(&bc, &i, OP_STACK_REF); */ +/* emit_word(&bc, &i, j+5); */ +/* emit(&bc, &i, OP_CONS); */ +/* emit(&bc, &i, OP_STACK_SET); */ +/* emit_word(&bc, &i, j+5); */ +/* emit(&bc, &i, OP_DROP); */ +/* } */ +/* } */ +/* sv = sexp_append(sv2, sv); */ +/* /\* determine internal defines *\/ */ +/* if (sexp_env_parent(e)) { */ +/* for (ls=SEXP_NULL; sexp_pairp(obj); obj=sexp_cdr(obj)) { */ +/* core = (sexp_pairp(sexp_car(obj)) && sexp_symbolp(sexp_caar(obj)) */ +/* ? core_code(e, sexp_caar(obj)) : 0); */ +/* if (core == CORE_BEGIN) { */ +/* obj = sexp_cons(sexp_car(obj), */ +/* sexp_append(sexp_cdar(obj), sexp_cdr(obj))); */ +/* } else { */ +/* if (core == CORE_DEFINE) { */ +/* if (! define_ok) */ +/* return sexp_compile_error("definition in non-definition context", */ +/* sexp_list1(obj)); */ +/* internals = sexp_cons(sexp_pairp(sexp_cadar(obj)) */ +/* ? sexp_car(sexp_cadar(obj)) : sexp_cadar(obj), */ +/* internals); */ +/* } else { */ +/* define_ok = 0; */ +/* } */ +/* ls = sexp_cons(sexp_car(obj), ls); */ +/* } */ +/* } */ +/* obj = sexp_reverse(ls); */ +/* j = sexp_unbox_integer(sexp_length(internals)); */ +/* if (sexp_pairp(internals)) { */ +/* e = extend_env(e, internals, d+j); */ +/* /\* XXXX params extended, need to recompute set-vars *\/ */ +/* params = sexp_append(internals, params); */ +/* for (ls=internals; sexp_pairp(ls); ls=sexp_cdr(ls)) */ +/* emit_push(&bc, &i, SEXP_UNDEF); */ +/* d+=j; */ +/* } */ +/* } */ +/* /\* analyze body sequence *\/ */ +/* analyze_sequence(obj, &bc, &i, e, params, fv, sv, &d, */ +/* (! done_p) && (! sexp_pairp(internals))); */ +/* if (sexp_pairp(internals)) { */ +/* emit(&bc, &i, OP_STACK_SET); */ +/* emit_word(&bc, &i, j+1); */ +/* for ( ; j>0; j--) */ +/* emit(&bc, &i, OP_DROP); */ +/* } */ +/* emit(&bc, &i, done_p ? OP_DONE : OP_RET); */ +/* shrink_bcode(&bc, i); */ +/* print_bytecode(bc); */ +/* disasm(bc); */ +/* return bc; */ +/* } */ /*********************** the virtual machine **************************/ @@ -772,9 +1214,9 @@ sexp_uint_t sexp_restore_stack(sexp saved, sexp *current) { #define sexp_raise(msg, args) do {stack[top]=sexp_compile_error(msg, args); top++; goto call_error_handler;} while (0) -sexp vm(sexp bc, sexp e, sexp* stack, sexp_sint_t top) { +sexp vm(sexp bc, sexp cp, sexp e, sexp* stack, sexp_sint_t top) { unsigned char *ip=sexp_bytecode_data(bc); - sexp cp=SEXP_UNDEF, tmp1, tmp2; + sexp tmp1, tmp2; sexp_sint_t i, j, k; loop: @@ -784,14 +1226,14 @@ sexp vm(sexp bc, sexp e, sexp* stack, sexp_sint_t top) { case OP_NOOP: fprintf(stderr, "noop\n"); break; - case OP_STACK_REF: + case OP_LOCAL_REF: /* fprintf(stderr, "STACK-REF[%ld - %ld = %ld]\n", top, */ /* (sexp_sint_t) ((sexp*)ip)[0], top - (sexp_sint_t) ((sexp*)ip)[0]); */ stack[top] = stack[top - (sexp_sint_t) ((sexp*)ip)[0]]; ip += sizeof(sexp); top++; break; - case OP_STACK_SET: + case OP_LOCAL_SET: /* fprintf(stderr, "STACK-SET[%ld - %ld = %ld]\n", top, */ /* (sexp_sint_t) ((sexp*)ip)[0], top - (sexp_sint_t) ((sexp*)ip)[0]); */ stack[top - (sexp_sint_t) ((sexp*)ip)[0]] = _ARG1; @@ -1114,13 +1556,13 @@ sexp vm(sexp bc, sexp e, sexp* stack, sexp_sint_t top) { break; case OP_JUMP_UNLESS: if (stack[--top] == SEXP_FALSE) { - ip += ((signed char*)ip)[0]; + ip += ((sexp_uint_t*)ip)[0]; } else { ip++; } break; case OP_JUMP: - ip += ((signed char*)ip)[0]; + ip += ((sexp_uint_t*)ip)[0]; break; case OP_DISPLAY: if (sexp_stringp(_ARG1)) { @@ -1187,14 +1629,14 @@ sexp sexp_close_port (sexp port) { } sexp sexp_load (sexp source) { - sexp obj, res, *stack = (sexp*) sexp_alloc(sizeof(sexp)*INIT_STACK_SIZE); + sexp obj, res, context = sexp_new_context(NULL); int closep = 0; if (sexp_stringp(source)) { source = sexp_open_input_file(source); closep = 1; } while ((obj=sexp_read(source)) != (sexp) SEXP_EOF) { - res = eval_in_stack(obj, interaction_environment, stack, 0); + res = eval_in_context(obj, interaction_environment, context); if (sexp_exceptionp(res)) goto done; } res = SEXP_UNDEF; @@ -1291,7 +1733,7 @@ _PARAM("interaction-environment", (sexp)&interaction_environment, SEXP_ENV), #undef _PARAM }; -sexp make_standard_env() { +sexp make_standard_env () { sexp_uint_t i; sexp e = sexp_alloc_type(env, SEXP_ENV); sexp_env_parent(e) = NULL; @@ -1305,22 +1747,46 @@ sexp make_standard_env() { /************************** eval interface ****************************/ -sexp eval_in_stack(sexp obj, sexp e, sexp* stack, sexp_sint_t top) { - sexp bc; - bc = compile(SEXP_NULL, sexp_cons(obj, SEXP_NULL), e, SEXP_NULL, SEXP_NULL, 1); - return vm(bc, e, stack, top); +/* args ... n ret-ip ret-cp */ +sexp apply(sexp proc, sexp args, sexp env, sexp context) { + sexp *stack = sexp_context_stack(context), ls; + sexp_sint_t top=0; + for (ls=args; sexp_pairp(ls); ls=sexp_cdr(ls)) + stack[top++] = sexp_car(ls); + stack[top] = sexp_make_integer(top); + top++; + stack[top++] + = sexp_make_integer(sexp_bytecode_data(sexp_procedure_code(final_resumer))); + stack[top++] = sexp_make_vector(0, SEXP_UNDEF); + return + vm(sexp_procedure_code(proc), sexp_procedure_vars(proc), env, stack, top); } -sexp eval(sexp obj, sexp e) { - sexp* stack = (sexp*) sexp_alloc(sizeof(sexp) * INIT_STACK_SIZE); - sexp res = eval_in_stack(obj, e, stack, 0); - sexp_free(stack); +sexp compile (sexp x, sexp env, sexp context) { + sexp ast, ctx; + analyze_bind(ast, x, env); + free_vars(ast, SEXP_NULL); /* should return SEXP_NULL */ + ctx = sexp_new_context(sexp_context_stack(context)); + compile_one(ast, ctx); + return sexp_make_procedure(sexp_make_integer(0), + sexp_make_integer(0), + finalize_bytecode(ctx), + sexp_make_vector(0, SEXP_UNDEF)); +} + +sexp eval_in_context (sexp obj, sexp env, sexp context) { + sexp thunk = compile(obj, env, context); + return apply(thunk, SEXP_NULL, env, context); +} + +sexp eval (sexp obj, sexp env) { + sexp context = sexp_new_context(NULL); + sexp res = eval_in_context(obj, env, context); return res; } -void scheme_init() { - sexp bc; - sexp_uint_t i=0; +void scheme_init () { + sexp context; if (! scheme_initialized_p) { scheme_initialized_p = 1; sexp_init(); @@ -1328,14 +1794,16 @@ void scheme_init() { cur_output_port = sexp_make_output_port(stdout); cur_error_port = sexp_make_output_port(stderr); the_compile_error_symbol = sexp_intern("compile-error"); - bc = sexp_alloc_tagged(sexp_sizeof(bytecode)+16, SEXP_BYTECODE); - sexp_bytecode_length(bc) = 16; - emit(&bc, &i, OP_RESUMECC); - continuation_resumer = (sexp) bc; + context = sexp_new_context(NULL); + emit(OP_RESUMECC, context); + continuation_resumer = finalize_bytecode(context); + context = sexp_extend_context(context, NULL); + emit(OP_DONE, context); + final_resumer = finalize_bytecode(context); } } -void repl (sexp e, sexp *stack) { +void repl (sexp env, sexp context) { sexp obj, res; while (1) { sexp_write_string("> ", cur_output_port); @@ -1343,7 +1811,7 @@ void repl (sexp e, sexp *stack) { obj = sexp_read(cur_input_port); if (obj == SEXP_EOF) break; - res = eval_in_stack(obj, e, stack, 0); + res = eval_in_context(obj, env, context); if (res != SEXP_UNDEF) { sexp_write(res, cur_output_port); sexp_write_char('\n', cur_output_port); @@ -1352,21 +1820,22 @@ void repl (sexp e, sexp *stack) { } int main (int argc, char **argv) { - sexp bc, e, obj, res, *stack, err_handler, err_handler_sym; + sexp bc, e, obj, res, *stack, context, err_handler, err_handler_sym; sexp_uint_t i, quit=0, init_loaded=0; scheme_init(); - stack = (sexp*) sexp_alloc(sizeof(sexp) * INIT_STACK_SIZE); +/* stack = (sexp*) sexp_alloc(sizeof(sexp) * INIT_STACK_SIZE); */ e = make_standard_env(); interaction_environment = e; - bc = sexp_alloc_tagged(sexp_sizeof(bytecode)+16, SEXP_BYTECODE); - sexp_bytecode_length(bc) = 16; - i = 0; - emit_push(&bc, &i, SEXP_UNDEF); - emit(&bc, &i, OP_DONE); +/* bc = sexp_alloc_tagged(sexp_sizeof(bytecode)+16, SEXP_BYTECODE); */ +/* sexp_bytecode_length(bc) = 16; */ +/* i = 0; */ + context = sexp_new_context(NULL); + emit_push(SEXP_UNDEF, context); + emit(OP_DONE, context); err_handler = sexp_make_procedure(sexp_make_integer(0), sexp_make_integer(0), - bc, + finalize_bytecode(context), sexp_make_vector(0, SEXP_UNDEF)); err_handler_sym = sexp_intern("*error-handler*"); env_define(e, err_handler_sym, err_handler); @@ -1382,7 +1851,7 @@ int main (int argc, char **argv) { init_loaded = 1; } obj = sexp_read_from_string(argv[i+1]); - res = eval_in_stack(obj, e, stack, 0); + res = eval_in_context(obj, e, context); if (argv[i][1] == 'p') { sexp_write(res, cur_output_port); sexp_write_char('\n', cur_output_port); @@ -1405,7 +1874,7 @@ int main (int argc, char **argv) { for ( ; i < argc; i++) sexp_load(sexp_make_string(argv[i])); else - repl(e, stack); + repl(e, context); } return 0; } diff --git a/eval.h b/eval.h index d20794d5..3ce55f52 100644 --- a/eval.h +++ b/eval.h @@ -70,8 +70,10 @@ enum opcode_names { OP_RET, OP_DONE, OP_PARAMETER, - OP_STACK_REF, - OP_STACK_SET, +/* OP_STACK_REF, */ +/* OP_STACK_SET, */ + OP_LOCAL_REF, + OP_LOCAL_SET, OP_CLOSURE_REF, OP_VECTOR_REF, OP_VECTOR_SET, @@ -122,26 +124,26 @@ enum opcode_names { /**************************** prototypes ******************************/ -sexp compile(sexp params, sexp obj, sexp e, sexp fv, sexp sv, int done_p); +/* sexp compile(sexp params, sexp obj, sexp e, sexp fv, sexp sv, int done_p); */ -sexp analyze_app(sexp obj, sexp *bc, sexp_uint_t *i, - sexp e, sexp params, sexp fv, sexp sv, - sexp_uint_t *d, int tailp); -sexp analyze_lambda(sexp name, sexp formals, sexp body, - sexp *bc, sexp_uint_t *i, sexp e, - sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp); -void analyze_var_ref(sexp name, sexp *bc, sexp_uint_t *i, sexp e, - sexp params, sexp fv, sexp sv, sexp_uint_t *d); -sexp analyze_opcode(sexp op, sexp obj, sexp *bc, sexp_uint_t *i, sexp e, - sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp); -sexp analyze(sexp obj, sexp *bc, sexp_uint_t *i, sexp e, - sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp); -sexp analyze_sequence(sexp ls, sexp *bc, sexp_uint_t *i, sexp e, - sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp); -sexp vm(sexp bc, sexp e, sexp* stack, sexp_sint_t top); +/* sexp analyze_app(sexp obj, sexp *bc, sexp_uint_t *i, */ +/* sexp e, sexp params, sexp fv, sexp sv, */ +/* sexp_uint_t *d, int tailp); */ +/* sexp analyze_lambda(sexp name, sexp formals, sexp body, */ +/* sexp *bc, sexp_uint_t *i, sexp e, */ +/* sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp); */ +/* void analyze_var_ref(sexp name, sexp *bc, sexp_uint_t *i, sexp e, */ +/* sexp params, sexp fv, sexp sv, sexp_uint_t *d); */ +/* sexp analyze_opcode(sexp op, sexp obj, sexp *bc, sexp_uint_t *i, sexp e, */ +/* sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp); */ +/* sexp analyze(sexp obj, sexp *bc, sexp_uint_t *i, sexp e, */ +/* sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp); */ +/* sexp analyze_sequence(sexp ls, sexp *bc, sexp_uint_t *i, sexp e, */ +/* sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp); */ +/* sexp vm(sexp bc, sexp cp, sexp e, sexp* stack, sexp_sint_t top); */ -sexp eval_in_stack(sexp expr, sexp e, sexp* stack, sexp_sint_t top); -sexp eval(sexp expr, sexp e); +sexp eval_in_context(sexp expr, sexp env, sexp context); +sexp eval(sexp expr, sexp env); #endif /* ! SEXP_EVAL_H */ diff --git a/sexp.c b/sexp.c index d01b2d50..4c90260d 100644 --- a/sexp.c +++ b/sexp.c @@ -54,7 +54,7 @@ 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 %d bytes for %d", + errx(EX_OSERR, "out of memory: couldn't allocate %ld bytes for %ld", size ,tag); res->tag = tag; return res; @@ -65,7 +65,7 @@ void sexp_deep_free (sexp obj) { int len, i; sexp *elts; if (sexp_pointerp(obj)) { - switch (obj->tag) { + switch (sexp_pointer_tag(obj)) { case SEXP_PAIR: sexp_deep_free(sexp_car(obj)); sexp_deep_free(sexp_cdr(obj)); @@ -191,6 +191,14 @@ sexp sexp_lset_diff(sexp a, sexp b) { 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)) @@ -421,7 +429,7 @@ void sexp_write (sexp obj, sexp out) { if (! obj) { sexp_write_string("#", out); } else if (sexp_pointerp(obj)) { - switch (sexp_tag(obj)) { + switch (sexp_pointer_tag(obj)) { case SEXP_PAIR: sexp_write_char('(', out); sexp_write(sexp_car(obj), out); diff --git a/sexp.h b/sexp.h index 9bc01269..84c83a5e 100644 --- a/sexp.h +++ b/sexp.h @@ -66,6 +66,7 @@ enum sexp_types { SEXP_SET, SEXP_SEQ, SEXP_LIT, + SEXP_CONTEXT, }; typedef unsigned long sexp_uint_t; @@ -104,7 +105,7 @@ struct sexp_struct { /* runtime types */ struct { char flags; - sexp parent, bindings; + sexp parent, lambda, bindings; } env; struct { sexp_uint_t length; @@ -133,7 +134,7 @@ struct sexp_struct { } core; /* ast types */ struct { - sexp name, params, flags, body, fv, sv; + sexp name, params, locals, flags, body, fv, sv; } lambda; struct { sexp test, pass, fail; @@ -142,14 +143,19 @@ struct sexp_struct { sexp var, value; } set; struct { - sexp var, value; + sexp name, loc; } ref; struct { sexp ls; } seq; struct { - sexp x; + sexp value; } lit; + /* compiler state */ + struct { + sexp bc, lambda, offsets, *stack; + sexp_uint_t pos, depth, tailp; + } context; } value; }; @@ -162,14 +168,18 @@ struct sexp_struct { #define SEXP_MAKE_IMMEDIATE(n) ((sexp) ((n<tag) +#define sexp_pointer_tag(x) ((x)->tag) -#define sexp_check_tag(x,t) (sexp_pointerp(x) && (sexp_tag(x) == (t))) +#define sexp_check_tag(x,t) (sexp_pointerp(x) && (sexp_pointer_tag(x) == (t))) #define sexp_pairp(x) (sexp_check_tag(x, SEXP_PAIR)) #define sexp_stringp(x) (sexp_check_tag(x, SEXP_STRING)) @@ -196,8 +206,17 @@ struct sexp_struct { #define sexp_corep(x) (sexp_check_tag(x, SEXP_CORE)) #define sexp_opcodep(x) (sexp_check_tag(x, SEXP_OPCODE)) #define sexp_macrop(x) (sexp_check_tag(x, SEXP_MACRO)) +#define sexp_synclop(x) (sexp_check_tag(x, SEXP_SYNCLO)) +#define sexp_lambdap(x) (sexp_check_tag(x, SEXP_LAMBDA)) +#define sexp_cndp(x) (sexp_check_tag(x, SEXP_CND)) +#define sexp_refp(x) (sexp_check_tag(x, SEXP_REF)) +#define sexp_setp(x) (sexp_check_tag(x, SEXP_SET)) +#define sexp_seqp(x) (sexp_check_tag(x, SEXP_SEQ)) +#define sexp_litp(x) (sexp_check_tag(x, SEXP_LIT)) #define sexp_symbolp(x) (sexp_isymbolp(x) || sexp_lsymbolp(x)) +/***************************** constructors ****************************/ + #define sexp_make_boolean(x) ((x) ? SEXP_TRUE : SEXP_FALSE) #define sexp_unbox_boolean(x) (((x) == SEXP_FALSE) ? 0 : 1) @@ -211,11 +230,13 @@ struct sexp_struct { #define sexp_integer_to_flonum(x) (sexp_make_flonum(sexp_unbox_integer(x))) +/*************************** field accessors **************************/ + #define sexp_vector_length(x) ((x)->value.vector.length) #define sexp_vector_data(x) ((x)->value.vector.data) -#define sexp_vector_ref(x, i) (sexp_vector_data(x)[sexp_unbox_integer(i)]) -#define sexp_vector_set(x, i, v) (sexp_vector_data(x)[sexp_unbox_integer(i)] = (v)) +#define sexp_vector_ref(x,i) (sexp_vector_data(x)[sexp_unbox_integer(i)]) +#define sexp_vector_set(x,i,v) (sexp_vector_data(x)[sexp_unbox_integer(i)]=(v)) #define sexp_procedure_num_args(x) ((x)->value.procedure.num_args) #define sexp_procedure_flags(x) ((x)->value.procedure.flags) @@ -250,10 +271,15 @@ struct sexp_struct { #define sexp_env_bindings(x) ((x)->value.env.bindings) #define sexp_env_local_p(x) (sexp_env_parent(x)) #define sexp_env_global_p(x) (! sexp_env_local_p(x)) +#define sexp_env_lambda(x) ((x)->value.env.lambda) #define sexp_macro_proc(x) ((x)->value.macro.proc) #define sexp_macro_env(x) ((x)->value.macro.env) +#define sexp_synclo_env(x) ((x)->value.synclo.env) +#define sexp_synclo_free_vars(x) ((x)->value.synclo.free_vars) +#define sexp_synclo_expr(x) ((x)->value.synclo.expr) + #define sexp_core_code(x) ((x)->value.core.code) #define sexp_core_name(x) ((x)->value.core.name) @@ -271,6 +297,81 @@ struct sexp_struct { #define sexp_opcode_variadic_p(x) (sexp_opcode_flags(x) & 1) #define sexp_opcode_opt_param_p(x) (sexp_opcode_flags(x) & 2) +#define sexp_lambda_name(x) ((x)->value.lambda.name) +#define sexp_lambda_params(x) ((x)->value.lambda.params) +#define sexp_lambda_locals(x) ((x)->value.lambda.locals) +#define sexp_lambda_flags(x) ((x)->value.lambda.flags) +#define sexp_lambda_body(x) ((x)->value.lambda.body) +#define sexp_lambda_fv(x) ((x)->value.lambda.fv) +#define sexp_lambda_sv(x) ((x)->value.lambda.sv) + +#define sexp_cnd_test(x) ((x)->value.cnd.test) +#define sexp_cnd_pass(x) ((x)->value.cnd.pass) +#define sexp_cnd_fail(x) ((x)->value.cnd.fail) + +#define sexp_set_var(x) ((x)->value.set.var) +#define sexp_set_value(x) ((x)->value.set.value) + +#define sexp_ref_name(x) ((x)->value.ref.name) +#define sexp_ref_loc(x) ((x)->value.ref.loc) + +#define sexp_seq_ls(x) ((x)->value.seq.ls) + +#define sexp_lit_value(x) ((x)->value.lit.value) + +#define sexp_context_stack(x) ((x)->value.context.stack) +#define sexp_context_depth(x) ((x)->value.context.depth) +#define sexp_context_bc(x) ((x)->value.context.bc) +#define sexp_context_pos(x) ((x)->value.context.pos) +#define sexp_context_lambda(x) ((x)->value.context.lambda) +#define sexp_context_offsets(x) ((x)->value.context.offsets) +#define sexp_context_tailp(x) ((x)->value.context.tailp) + +/****************************** arithmetic ****************************/ + +#define sexp_fx_add(a, b) ((sexp)(((sexp_sint_t)a)+((sexp_sint_t)b)-SEXP_FIXNUM_TAG)) +#define sexp_fx_sub(a, b) ((sexp)(((sexp_sint_t)a)-((sexp_sint_t)b)+SEXP_FIXNUM_TAG)) +#define sexp_fx_mul(a, b) ((sexp)((((((sexp_sint_t)a)-SEXP_FIXNUM_TAG)*(((sexp_sint_t)b)>>SEXP_FIXNUM_BITS))+SEXP_FIXNUM_TAG))) +#define sexp_fx_div(a, b) (sexp_make_integer(sexp_unbox_integer(a) / sexp_unbox_integer(b))) +#define sexp_fx_mod(a, b) (sexp_make_integer(sexp_unbox_integer(a) % sexp_unbox_integer(b))) + +#define sexp_fp_add(a, b) (sexp_make_flonum(sexp_flonum_value(a) + sexp_flonum_value(b))) +#define sexp_fp_sub(a, b) (sexp_make_flonum(sexp_flonum_value(a) - sexp_flonum_value(b))) +#define sexp_fp_mul(a, b) (sexp_make_flonum(sexp_flonum_value(a) * sexp_flonum_value(b))) +#define sexp_fp_div(a, b) (sexp_make_flonum(sexp_flonum_value(a) / sexp_flonum_value(b))) + +/****************************** utilities *****************************/ + +#define sexp_list1(a) sexp_cons(a, SEXP_NULL) +#define sexp_list2(a, b) sexp_cons(a, sexp_cons(b, SEXP_NULL)) +#define sexp_list3(a, b, c) sexp_cons(a, sexp_cons(b, sexp_cons(c, SEXP_NULL))) +#define sexp_list4(a, b, c, d) sexp_cons(a, sexp_cons(b, sexp_cons(c, sexp_cons(d, SEXP_NULL)))) + +#define sexp_push(ls, x) ((ls) = sexp_cons((x), (ls))) +#define sexp_insert(ls, x) ((sexp_list_index((ls), (x)) >= 0) ? (ls) : sexp_push((ls), (x))) + +#define sexp_car(x) ((x)->value.pair.car) +#define sexp_cdr(x) ((x)->value.pair.cdr) + +#define sexp_caar(x) (sexp_car(sexp_car(x))) +#define sexp_cadr(x) (sexp_car(sexp_cdr(x))) +#define sexp_cdar(x) (sexp_cdr(sexp_car(x))) +#define sexp_cddr(x) (sexp_cdr(sexp_cdr(x))) + +#define sexp_caaar(x) (sexp_car(sexp_caar(x))) +#define sexp_caadr(x) (sexp_car(sexp_cadr(x))) +#define sexp_cadar(x) (sexp_car(sexp_cdar(x))) +#define sexp_caddr(x) (sexp_car(sexp_cddr(x))) +#define sexp_cdaar(x) (sexp_cdr(sexp_caar(x))) +#define sexp_cdadr(x) (sexp_cdr(sexp_cadr(x))) +#define sexp_cddar(x) (sexp_cdr(sexp_cdar(x))) +#define sexp_cdddr(x) (sexp_cdr(sexp_cddr(x))) + +#define sexp_cadddr(x) (sexp_cadr(sexp_cddr(x))) +#define sexp_cddddr(x) (sexp_cddr(sexp_cddr(x))) + +/***************************** general API ****************************/ + #if USE_STRING_STREAMS #if SEXP_BSD #define fmemopen(str, len, m) funopen(sexp_vector(3, (sexp)str, (sexp)len, (sexp)0), sstream_read, sstream_write, sstream_seek, sstream_close) @@ -293,47 +394,14 @@ void sexp_write_string(sexp str, sexp port); void sexp_printf(sexp port, sexp fmt, ...); #endif -#define sexp_fx_add(a, b) ((sexp)(((sexp_sint_t)a)+((sexp_sint_t)b)-SEXP_FIXNUM_TAG)) -#define sexp_fx_sub(a, b) ((sexp)(((sexp_sint_t)a)-((sexp_sint_t)b)+SEXP_FIXNUM_TAG)) -#define sexp_fx_mul(a, b) ((sexp)((((((sexp_sint_t)a)-SEXP_FIXNUM_TAG)*(((sexp_sint_t)b)>>SEXP_FIXNUM_BITS))+SEXP_FIXNUM_TAG))) -#define sexp_fx_div(a, b) (sexp_make_integer(sexp_unbox_integer(a) / sexp_unbox_integer(b))) -#define sexp_fx_mod(a, b) (sexp_make_integer(sexp_unbox_integer(a) % sexp_unbox_integer(b))) - -#define sexp_fp_add(a, b) (sexp_make_flonum(sexp_flonum_value(a) + sexp_flonum_value(b))) -#define sexp_fp_sub(a, b) (sexp_make_flonum(sexp_flonum_value(a) - sexp_flonum_value(b))) -#define sexp_fp_mul(a, b) (sexp_make_flonum(sexp_flonum_value(a) * sexp_flonum_value(b))) -#define sexp_fp_div(a, b) (sexp_make_flonum(sexp_flonum_value(a) / sexp_flonum_value(b))) - -#define sexp_list1(a) sexp_cons(a, SEXP_NULL) -#define sexp_list2(a, b) sexp_cons(a, sexp_cons(b, SEXP_NULL)) -#define sexp_list3(a, b, c) sexp_cons(a, sexp_cons(b, sexp_cons(c, SEXP_NULL))) -#define sexp_list4(a, b, c, d) sexp_cons(a, sexp_cons(b, sexp_cons(c, sexp_cons(d, SEXP_NULL)))) - -#define sexp_car(x) ((x)->value.pair.car) -#define sexp_cdr(x) ((x)->value.pair.cdr) - -#define sexp_caar(x) (sexp_car(sexp_car(x))) -#define sexp_cadr(x) (sexp_car(sexp_cdr(x))) -#define sexp_cdar(x) (sexp_cdr(sexp_car(x))) -#define sexp_cddr(x) (sexp_cdr(sexp_cdr(x))) - -#define sexp_caaar(x) (sexp_car(sexp_caar(x))) -#define sexp_caadr(x) (sexp_car(sexp_cadr(x))) -#define sexp_cadar(x) (sexp_car(sexp_cdar(x))) -#define sexp_caddr(x) (sexp_car(sexp_cddr(x))) -#define sexp_cdaar(x) (sexp_cdr(sexp_caar(x))) -#define sexp_cdadr(x) (sexp_cdr(sexp_cadr(x))) -#define sexp_cddar(x) (sexp_cdr(sexp_cdar(x))) -#define sexp_cdddr(x) (sexp_cdr(sexp_cddr(x))) - -#define sexp_cadddr(x) (sexp_cadr(sexp_cddr(x))) -#define sexp_cddddr(x) (sexp_cddr(sexp_cddr(x))) +/***************************** general API ****************************/ sexp sexp_alloc_tagged(size_t size, sexp_uint_t tag); sexp sexp_cons(sexp head, sexp tail); int sexp_listp(sexp obj); int sexp_list_index(sexp ls, sexp elt); sexp sexp_lset_diff(sexp a, sexp b); +/* sexp sexp_lset_union(sexp a, sexp b); */ sexp sexp_reverse(sexp ls); sexp sexp_nreverse(sexp ls); sexp sexp_append(sexp a, sexp b); From 68c7fc8f8031db787e05b8797353a4466f100d25 Mon Sep 17 00:00:00 2001 From: foof Date: Wed, 25 Mar 2009 03:12:56 -0400 Subject: [PATCH 047/154] forgot to include .hgignore file --- .hgignore | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) create mode 100644 .hgignore diff --git a/.hgignore b/.hgignore new file mode 100644 index 00000000..dce70adb --- /dev/null +++ b/.hgignore @@ -0,0 +1,20 @@ +syntax: glob +*~ +*.i +*.s +*.o +*.so +*.dSYM +*.orig +.hg +junk* +*.tar.gz +*.tar.bz2 +*.log +*.err +*.res +*.out +gc +gc6.8 +chibi-scheme + From 989803f2d2a2ed8dbde18d735ed2aa43343dae8f Mon Sep 17 00:00:00 2001 From: alexander-s Date: Wed, 25 Mar 2009 16:13:45 +0900 Subject: [PATCH 048/154] fixing gc.a target --- Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Makefile b/Makefile index b91568d8..93c552a4 100644 --- a/Makefile +++ b/Makefile @@ -7,7 +7,7 @@ CFLAGS=-Wall -g -fno-inline -save-temps -Os GC_OBJ=./gc/gc.a -$GC_OBJ: ./gc/alloc.c +./gc/gc.a: ./gc/alloc.c cd gc && make test sexp.o: sexp.c sexp.h config.h defaults.h Makefile From ab82735500448317a8fd0f3f153d37c9b97761ca Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Wed, 25 Mar 2009 23:59:01 +0900 Subject: [PATCH 049/154] back to basics - literals and opcodes work --- eval.c | 87 +++++++++++++++++++++++++++++++++------------------------- sexp.c | 2 +- 2 files changed, 51 insertions(+), 38 deletions(-) diff --git a/eval.c b/eval.c index b51d5034..929c8206 100644 --- a/eval.c +++ b/eval.c @@ -74,15 +74,15 @@ static sexp env_cell_create(sexp e, sexp key, sexp value) { return cell; } -static int env_global_p (sexp e, sexp id) { - while (sexp_env_parent(e)) { - if (sexp_assq(id, sexp_env_bindings(e)) != SEXP_FALSE) - return 0; - else - e = sexp_env_parent(e); - } - return 1; -} +/* static int env_global_p (sexp e, sexp id) { */ +/* while (sexp_env_parent(e)) { */ +/* if (sexp_assq(id, sexp_env_bindings(e)) != SEXP_FALSE) */ +/* return 0; */ +/* else */ +/* e = sexp_env_parent(e); */ +/* } */ +/* return 1; */ +/* } */ static void env_define(sexp e, sexp key, sexp value) { sexp cell = sexp_assq(key, sexp_env_bindings(e)); @@ -101,11 +101,11 @@ static sexp extend_env (sexp env, sexp vars, sexp value) { return e; } -static int core_code (sexp e, sexp sym) { - sexp cell = env_cell(e, sym); - if (! cell || ! sexp_corep(sexp_cdr(cell))) return 0; - return (sexp_core_code(sexp_cdr(cell))); -} +/* static int core_code (sexp e, sexp sym) { */ +/* sexp cell = env_cell(e, sym); */ +/* if (! cell || ! sexp_corep(sexp_cdr(cell))) return 0; */ +/* return (sexp_core_code(sexp_cdr(cell))); */ +/* } */ static sexp sexp_reverse_flatten_dot (sexp ls) { sexp res; @@ -214,6 +214,7 @@ static sexp sexp_new_context(sexp *stack) { sexp_context_bc(res) = sexp_alloc_tagged(sexp_sizeof(bytecode)+INIT_BCODE_SIZE, SEXP_BYTECODE); sexp_bytecode_length(sexp_context_bc(res)) = INIT_BCODE_SIZE; + sexp_context_lambda(res) = SEXP_FALSE; sexp_context_stack(res) = stack; sexp_context_depth(res) = 0; sexp_context_pos(res) = 0; @@ -307,6 +308,10 @@ sexp analyze (sexp x, sexp env) { /* x = expand_macro(op, x, env); */ /* goto loop; */ res = sexp_compile_error("macros not yet supported", sexp_list1(x)); + } else if (sexp_opcodep(op)) { + res = analyze_app(sexp_cdr(x), env); + analyze_check_exception(res); + sexp_push(res, op); } else { res = analyze_app(x, env); } @@ -418,6 +423,7 @@ void sexp_context_patch_label (sexp context, sexp_uint_t label) { static sexp finalize_bytecode (sexp context) { emit(OP_RET, context); shrink_bcode(context, sexp_context_pos(context)); + disasm(sexp_context_bc(context)); return sexp_context_bc(context); } @@ -1209,6 +1215,7 @@ sexp_uint_t sexp_restore_stack(sexp saved, sexp *current) { #define _ARG2 stack[top-2] #define _ARG3 stack[top-3] #define _ARG4 stack[top-4] +#define _ARG5 stack[top-5] #define _PUSH(x) (stack[top++]=(x)) #define _POP() (stack[--top]) @@ -1217,11 +1224,11 @@ sexp_uint_t sexp_restore_stack(sexp saved, sexp *current) { sexp vm(sexp bc, sexp cp, sexp e, sexp* stack, sexp_sint_t top) { unsigned char *ip=sexp_bytecode_data(bc); sexp tmp1, tmp2; - sexp_sint_t i, j, k; + sexp_sint_t i, j, k, fp=top-4; loop: -/* print_stack(stack, top); */ -/* fprintf(stderr, "OP: %s (%d)\n", (*ip<=71) ? reverse_opcode_names[*ip] : "", *ip); */ + print_stack(stack, top); + fprintf(stderr, "OP: %s (%d)\n", (*ip<=71) ? reverse_opcode_names[*ip] : "", *ip); switch (*ip++) { case OP_NOOP: fprintf(stderr, "noop\n"); @@ -1229,14 +1236,15 @@ sexp vm(sexp bc, sexp cp, sexp e, sexp* stack, sexp_sint_t top) { case OP_LOCAL_REF: /* fprintf(stderr, "STACK-REF[%ld - %ld = %ld]\n", top, */ /* (sexp_sint_t) ((sexp*)ip)[0], top - (sexp_sint_t) ((sexp*)ip)[0]); */ - stack[top] = stack[top - (sexp_sint_t) ((sexp*)ip)[0]]; + /* stack[top] = stack[top - (sexp_sint_t) ((sexp*)ip)[0]]; */ + stack[top] = stack[fp - (sexp_sint_t) ((sexp*)ip)[0]]; ip += sizeof(sexp); top++; break; case OP_LOCAL_SET: /* fprintf(stderr, "STACK-SET[%ld - %ld = %ld]\n", top, */ /* (sexp_sint_t) ((sexp*)ip)[0], top - (sexp_sint_t) ((sexp*)ip)[0]); */ - stack[top - (sexp_sint_t) ((sexp*)ip)[0]] = _ARG1; + stack[fp - (sexp_sint_t) ((sexp*)ip)[0]] = _ARG1; _ARG1 = SEXP_UNDEF; ip += sizeof(sexp); break; @@ -1485,10 +1493,12 @@ sexp vm(sexp bc, sexp cp, sexp e, sexp* stack, sexp_sint_t top) { _ARG1 = sexp_make_integer(i); stack[top] = sexp_make_integer(ip+sizeof(sexp)); stack[top+1] = cp; - top+=2; + stack[top+2] = (sexp) fp; + top+=3; bc = sexp_procedure_code(tmp1); ip = sexp_bytecode_data(bc); cp = sexp_procedure_vars(tmp1); + fp = top-4; break; case OP_APPLY1: tmp1 = _ARG1; @@ -1594,15 +1604,18 @@ sexp vm(sexp bc, sexp cp, sexp e, sexp* stack, sexp_sint_t top) { _ARG1 = (i == EOF) ? SEXP_EOF : sexp_make_character(i); break; case OP_RET: - if (top<4) - goto end_loop; - cp = _ARG2; - ip = (unsigned char*) sexp_unbox_integer(_ARG3); - i = sexp_unbox_integer(_ARG4); - stack[top-i-4] = _ARG1; - top = top-i-3; +/* if (top<4) */ +/* goto end_loop; */ + fp = (sexp_sint_t) _ARG2; + cp = _ARG3; + ip = (unsigned char*) sexp_unbox_integer(_ARG4); + i = sexp_unbox_integer(_ARG5); + stack[top-i-5] = _ARG1; + top = top-i-4; + fprintf(stderr, "returning to %p (i=%ld)\n", ip, i); break; case OP_DONE: + fprintf(stderr, "done!\n"); goto end_loop; default: sexp_raise("unknown opcode", sexp_list1(sexp_make_integer(*(ip-1)))); @@ -1747,7 +1760,7 @@ sexp make_standard_env () { /************************** eval interface ****************************/ -/* args ... n ret-ip ret-cp */ +/* args ... n ret-ip ret-cp ret-fp */ sexp apply(sexp proc, sexp args, sexp env, sexp context) { sexp *stack = sexp_context_stack(context), ls; sexp_sint_t top=0; @@ -1755,9 +1768,9 @@ sexp apply(sexp proc, sexp args, sexp env, sexp context) { stack[top++] = sexp_car(ls); stack[top] = sexp_make_integer(top); top++; - stack[top++] - = sexp_make_integer(sexp_bytecode_data(sexp_procedure_code(final_resumer))); + stack[top++] = sexp_make_integer(sexp_bytecode_data(final_resumer)); stack[top++] = sexp_make_vector(0, SEXP_UNDEF); + stack[top++] = sexp_make_integer(0); return vm(sexp_procedure_code(proc), sexp_procedure_vars(proc), env, stack, top); } @@ -1820,13 +1833,13 @@ void repl (sexp env, sexp context) { } int main (int argc, char **argv) { - sexp bc, e, obj, res, *stack, context, err_handler, err_handler_sym; + sexp env, obj, res, context, err_handler, err_handler_sym; sexp_uint_t i, quit=0, init_loaded=0; scheme_init(); /* stack = (sexp*) sexp_alloc(sizeof(sexp) * INIT_STACK_SIZE); */ - e = make_standard_env(); - interaction_environment = e; + env = make_standard_env(); + interaction_environment = env; /* bc = sexp_alloc_tagged(sexp_sizeof(bytecode)+16, SEXP_BYTECODE); */ /* sexp_bytecode_length(bc) = 16; */ /* i = 0; */ @@ -1838,8 +1851,8 @@ int main (int argc, char **argv) { finalize_bytecode(context), sexp_make_vector(0, SEXP_UNDEF)); err_handler_sym = sexp_intern("*error-handler*"); - env_define(e, err_handler_sym, err_handler); - exception_handler_cell = env_cell(e, err_handler_sym); + env_define(env, err_handler_sym, err_handler); + exception_handler_cell = env_cell(env, err_handler_sym); /* parse options */ for (i=1; i < argc && argv[i][0] == '-'; i++) { @@ -1851,7 +1864,7 @@ int main (int argc, char **argv) { init_loaded = 1; } obj = sexp_read_from_string(argv[i+1]); - res = eval_in_context(obj, e, context); + res = eval_in_context(obj, env, context); if (argv[i][1] == 'p') { sexp_write(res, cur_output_port); sexp_write_char('\n', cur_output_port); @@ -1874,7 +1887,7 @@ int main (int argc, char **argv) { for ( ; i < argc; i++) sexp_load(sexp_make_string(argv[i])); else - repl(e, context); + repl(env, context); } return 0; } diff --git a/sexp.c b/sexp.c index 4c90260d..0519207e 100644 --- a/sexp.c +++ b/sexp.c @@ -56,7 +56,7 @@ sexp sexp_alloc_tagged(size_t size, sexp_uint_t tag) { if (! res) errx(EX_OSERR, "out of memory: couldn't allocate %ld bytes for %ld", size ,tag); - res->tag = tag; + sexp_pointer_tag(res) = tag; return res; } From c6c1c00c5839fe838d9ec45312af8b86c062bfa9 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 26 Mar 2009 00:15:47 +0900 Subject: [PATCH 050/154] definitions working --- eval.c | 16 ++++++++-------- sexp.h | 5 +++-- 2 files changed, 11 insertions(+), 10 deletions(-) diff --git a/eval.c b/eval.c index 929c8206..b0160045 100644 --- a/eval.c +++ b/eval.c @@ -186,10 +186,10 @@ static sexp sexp_make_set(sexp var, sexp value) { return res; } -static sexp sexp_make_ref(sexp name, sexp loc) { +static sexp sexp_make_ref(sexp name, sexp cell) { sexp res = sexp_alloc_type(ref, SEXP_REF); sexp_ref_name(res) = name; - sexp_ref_loc(res) = loc; + sexp_ref_cell(res) = cell; return res; } @@ -378,7 +378,7 @@ sexp analyze_app (sexp x, sexp env) { sexp analyze_define (sexp x, sexp env) { sexp ref, name, value; name = (sexp_pairp(sexp_cadr(x)) ? sexp_caadr(x) : sexp_cadr(x)); - if (sexp_lambdap(sexp_env_lambda(env))) + if (sexp_env_lambda(env) && sexp_lambdap(sexp_env_lambda(env))) sexp_push(sexp_lambda_locals(sexp_env_lambda(env)), name); if (sexp_pairp(sexp_cadr(x))) value = analyze_lambda(sexp_cons(SEXP_UNDEF, @@ -395,7 +395,7 @@ sexp analyze_define (sexp x, sexp env) { sexp analyze_var_ref (sexp x, sexp env) { sexp cell = env_cell_create(env, x, SEXP_UNDEF); - return sexp_make_ref(x, sexp_cdr(cell)); + return sexp_make_ref(x, cell); } sexp analyze_set (sexp x, sexp env) { @@ -492,7 +492,7 @@ void compile_ref (sexp ref, sexp context, int unboxp) { sexp lam; if (! sexp_lambdap(sexp_ref_loc(ref))) { /* global ref */ - emit_push(ref, context); + emit_push(sexp_ref_cell(ref), context); emit(OP_CDR, context); } else { lam = sexp_context_lambda(context); @@ -501,10 +501,10 @@ void compile_ref (sexp ref, sexp context, int unboxp) { } } -void compile_non_global_ref (sexp name, sexp loc, sexp lambda, sexp fv, +void compile_non_global_ref (sexp name, sexp cell, sexp lambda, sexp fv, sexp context, int unboxp) { - sexp ls; sexp_uint_t i; + sexp ls, loc = sexp_cdr(cell); if (loc == lambda) { /* local ref */ emit(OP_LOCAL_REF, context); @@ -528,7 +528,7 @@ void compile_set (sexp set, sexp context) { compile_one(sexp_set_value(set), context); if (! sexp_lambdap(sexp_ref_loc(ref))) { /* global vars are set directly */ - emit_push(ref, context); + emit_push(sexp_ref_cell(ref), context); } else { /* stack or closure mutable vars are boxed */ compile_ref(ref, context, 0); diff --git a/sexp.h b/sexp.h index 84c83a5e..6ca35e0b 100644 --- a/sexp.h +++ b/sexp.h @@ -143,7 +143,7 @@ struct sexp_struct { sexp var, value; } set; struct { - sexp name, loc; + sexp name, cell; } ref; struct { sexp ls; @@ -313,7 +313,8 @@ struct sexp_struct { #define sexp_set_value(x) ((x)->value.set.value) #define sexp_ref_name(x) ((x)->value.ref.name) -#define sexp_ref_loc(x) ((x)->value.ref.loc) +#define sexp_ref_cell(x) ((x)->value.ref.cell) +#define sexp_ref_loc(x) (sexp_cdr(sexp_ref_cell(x))) #define sexp_seq_ls(x) ((x)->value.seq.ls) From fdbf99b433fea6fd412d229b4c649d5f72fb056c Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 26 Mar 2009 01:34:47 +0900 Subject: [PATCH 051/154] local variable references work --- debug.c | 4 +- eval.c | 539 ++++---------------------------------------------------- sexp.c | 9 +- 3 files changed, 48 insertions(+), 504 deletions(-) diff --git a/debug.c b/debug.c index bb80564c..2145e4b4 100644 --- a/debug.c +++ b/debug.c @@ -82,10 +82,10 @@ void print_bytecode (sexp bc) { } } -void print_stack (sexp *stack, int top) { +void print_stack (sexp *stack, int top, int fp) { int i; for (i=0; i "); *\/ */ -/* bc = sexp_alloc_tagged(sexp_sizeof(bytecode)+64, SEXP_BYTECODE); */ -/* sexp_bytecode_length(bc) = 32; */ -/* emit_push(&bc, &i, sexp_macro_env(mac)); */ -/* emit_push(&bc, &i, e); */ -/* emit_push(&bc, &i, form); */ -/* emit_push(&bc, &i, sexp_macro_proc(mac)); */ -/* emit(&bc, &i, OP_CALL); */ -/* emit_word(&bc, &i, (sexp_uint_t) sexp_make_integer(3)); */ -/* emit(&bc, &i, OP_DONE); */ -/* res = vm(bc, e, stack, 0); */ -/* sexp_write(res, cur_error_port); */ -/* /\* fprintf(stderr, "\n"); *\/ */ -/* sexp_free(bc); */ -/* sexp_free(stack); */ -/* return res; */ -/* } */ - #define analyze_check_exception(x) do {if (sexp_exceptionp(x)) \ return (x); \ } while (0) @@ -275,6 +246,9 @@ static sexp sexp_compile_error(char *message, sexp irritants) { sexp analyze (sexp x, sexp env) { sexp op, cell, res; loop: + fprintf(stderr, "analyze: "); + sexp_write(x, cur_error_port); + fprintf(stderr, "\n"); if (sexp_pairp(x)) { if (sexp_idp(sexp_car(x))) { cell = env_cell(env, sexp_car(x)); @@ -335,6 +309,8 @@ sexp analyze_lambda (sexp x, sexp env) { /* XXXX verify syntax */ res = sexp_alloc_type(lambda, SEXP_LAMBDA); sexp_lambda_params(res) = sexp_cadr(x); + sexp_lambda_fv(res) = SEXP_NULL; + sexp_lambda_sv(res) = SEXP_NULL; env = extend_env(env, sexp_flatten_dot(sexp_lambda_params(res)), res); sexp_env_lambda(env) = res; body = analyze_seq(sexp_cddr(x), env); @@ -395,6 +371,8 @@ sexp analyze_define (sexp x, sexp env) { sexp analyze_var_ref (sexp x, sexp env) { sexp cell = env_cell_create(env, x, SEXP_UNDEF); + if (! cell) + fprintf(stderr, "can't happen, env_cell_create => NULL\n"); return sexp_make_ref(x, cell); } @@ -493,10 +471,11 @@ void compile_ref (sexp ref, sexp context, int unboxp) { if (! sexp_lambdap(sexp_ref_loc(ref))) { /* global ref */ emit_push(sexp_ref_cell(ref), context); - emit(OP_CDR, context); + if (unboxp) + emit(OP_CDR, context); } else { lam = sexp_context_lambda(context); - compile_non_global_ref(sexp_ref_name(ref), sexp_ref_loc(ref), lam, + compile_non_global_ref(sexp_ref_name(ref), sexp_ref_cell(ref), lam, sexp_lambda_fv(lam), context, unboxp); } } @@ -504,14 +483,16 @@ void compile_ref (sexp ref, sexp context, int unboxp) { void compile_non_global_ref (sexp name, sexp cell, sexp lambda, sexp fv, sexp context, int unboxp) { sexp_uint_t i; - sexp ls, loc = sexp_cdr(cell); - if (loc == lambda) { + sexp loc = sexp_cdr(cell); + sexp_debug("cell: ", cell); + if (loc == lambda && sexp_lambdap(lambda)) { /* local ref */ + sexp_debug("params: ", sexp_lambda_params(lambda)); emit(OP_LOCAL_REF, context); emit_word(sexp_list_index(sexp_lambda_params(lambda), name), context); } else { /* closure ref */ - for (i=0; sexp_pairp(fv); ls=sexp_cdr(fv), i++) + for (i=0; sexp_pairp(fv); fv=sexp_cdr(fv), i++) if (name == sexp_car(fv) && loc == sexp_cdr(fv)) break; emit(OP_CLOSURE_REF, context); @@ -627,7 +608,7 @@ void compile_lambda (sexp lambda, sexp context) { sexp fv, ctx, flags, bc, len, ref, vec, prev_lambda, prev_fv; sexp_uint_t k; prev_lambda = sexp_context_lambda(context); - prev_fv = sexp_lambda_fv(prev_lambda); + prev_fv = sexp_lambdap(prev_lambda) ? sexp_lambda_fv(prev_lambda) : SEXP_NULL; fv = sexp_lambda_fv(lambda); ctx = sexp_new_context(sexp_context_stack(context)); sexp_context_lambda(ctx) = lambda; @@ -646,7 +627,7 @@ void compile_lambda (sexp lambda, sexp context) { sexp_context_depth(context)--; for (k=0; sexp_pairp(fv); fv=sexp_cdr(fv), k++) { ref = sexp_car(fv); - compile_non_global_ref(sexp_ref_name(ref), sexp_ref_loc(ref), + compile_non_global_ref(sexp_ref_name(ref), sexp_ref_cell(ref), prev_lambda, prev_fv, context, 1); emit_push(sexp_make_integer(k), context); emit(OP_LOCAL_REF, context); @@ -663,319 +644,6 @@ void compile_lambda (sexp lambda, sexp context) { } } -/* sexp xanalyze(sexp obj, sexp *bc, sexp_uint_t *i, sexp e, */ -/* sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp) { */ -/* int tmp1, tmp2; */ -/* sexp o1, o2, e2, cell, exn; */ - -/* loop: */ -/* if (sexp_pairp(obj)) { */ -/* if (sexp_symbolp(sexp_car(obj))) { */ -/* o1 = env_cell(e, sexp_car(obj)); */ -/* if (! o1) { */ -/* return analyze_app(obj, bc, i, e, params, fv, sv, d, tailp); */ -/* } */ -/* o1 = sexp_cdr(o1); */ -/* if (sexp_corep(o1)) { */ -/* switch (sexp_core_code(o1)) { */ -/* case CORE_LAMBDA: */ -/* return analyze_lambda(SEXP_FALSE, sexp_cadr(obj), sexp_cddr(obj), */ -/* bc, i, e, params, fv, sv, d, tailp); */ -/* case CORE_DEFINE_SYNTAX: */ -/* o2 = eval(sexp_caddr(obj), e); */ -/* if (sexp_exceptionp(o2)) return o2; */ -/* env_define(e, sexp_cadr(obj), sexp_make_macro(o2, e)); */ -/* emit_push(bc, i, SEXP_UNDEF); */ -/* (*d)++; */ -/* break; */ -/* case CORE_DEFINE: */ -/* if ((sexp_core_code(o1) == CORE_DEFINE) */ -/* && sexp_pairp(sexp_cadr(obj))) { */ -/* o2 = sexp_car(sexp_cadr(obj)); */ -/* exn = analyze_lambda(sexp_caadr(obj), sexp_cdadr(obj), */ -/* sexp_cddr(obj), */ -/* bc, i, e, params, fv, sv, d, 0); */ -/* } else { */ -/* o2 = sexp_cadr(obj); */ -/* exn = analyze(sexp_caddr(obj), bc, i, e, params, fv, sv, d, 0); */ -/* } */ -/* if (sexp_exceptionp(exn)) return exn; */ -/* if (sexp_env_global_p(e)) { */ -/* cell = env_cell_create(e, o2); */ -/* emit_push(bc, i, cell); */ -/* emit(bc, i, OP_SET_CDR); */ -/* } else { */ -/* cell = env_cell(e, o2); */ -/* if (! cell || ! sexp_integerp(sexp_cdr(cell))) { */ -/* return sexp_compile_error("define in bad position", */ -/* sexp_list1(obj)); */ -/* } else { */ -/* emit(bc, i, OP_STACK_SET); */ -/* emit_word(bc, i, (*d)+1-sexp_unbox_integer(sexp_cdr(cell))); */ -/* } */ -/* } */ -/* (*d)++; */ -/* break; */ -/* case CORE_SET: */ -/* exn = analyze(sexp_caddr(obj), bc, i, e, params, fv, sv, d, 0); */ -/* if (sexp_exceptionp(exn)) return exn; */ -/* if (sexp_list_index(sv, sexp_cadr(obj)) >= 0) { */ -/* analyze_var_ref(sexp_cadr(obj), bc, i, e, params, fv, SEXP_NULL, d); */ -/* emit(bc, i, OP_SET_CAR); */ -/* (*d)--; */ -/* } else { */ -/* cell = env_cell_create(e, sexp_cadr(obj)); */ -/* emit_push(bc, i, cell); */ -/* emit(bc, i, OP_SET_CDR); */ -/* } */ -/* break; */ -/* case CORE_BEGIN: */ -/* return */ -/* analyze_sequence(sexp_cdr(obj), bc, i, e, params, fv, sv, d, tailp); */ -/* case CORE_IF: */ -/* exn = analyze(sexp_cadr(obj), bc, i, e, params, fv, sv, d, 0); */ -/* if (sexp_exceptionp(exn)) return exn; */ -/* emit(bc, i, OP_JUMP_UNLESS); /\* jumps if test fails *\/ */ -/* (*d)--; */ -/* tmp1 = *i; */ -/* emit(bc, i, 0); */ -/* exn = analyze(sexp_caddr(obj), bc, i, e, params, fv, sv, d, tailp); */ -/* if (sexp_exceptionp(exn)) return exn; */ -/* emit(bc, i, OP_JUMP); */ -/* (*d)--; */ -/* tmp2 = *i; */ -/* emit(bc, i, 0); */ -/* ((signed char*) sexp_bytecode_data(*bc))[tmp1] = (*i)-tmp1; */ -/* if (sexp_pairp(sexp_cdddr(obj))) { */ -/* exn = analyze(sexp_cadddr(obj), bc, i, e, params, fv, sv, d, tailp); */ -/* if (sexp_exceptionp(exn)) return exn; */ -/* } else { */ -/* emit_push(bc, i, SEXP_UNDEF); */ -/* (*d)++; */ -/* } */ -/* ((signed char*) sexp_bytecode_data(*bc))[tmp2] = (*i)-tmp2; */ -/* break; */ -/* case CORE_QUOTE: */ -/* emit_push(bc, i, sexp_cadr(obj)); */ -/* (*d)++; */ -/* break; */ -/* default: */ -/* return sexp_compile_error("unknown core form", sexp_list1(o1)); */ -/* } */ -/* } else if (sexp_opcodep(o1)) { */ -/* return analyze_opcode(o1, obj, bc, i, e, params, fv, sv, d, tailp); */ -/* } else if (sexp_macrop(o1)) { */ -/* obj = sexp_expand_macro(o1, obj, e); */ -/* if (sexp_exceptionp(obj)) return obj; */ -/* goto loop; */ -/* } else { */ -/* /\* general procedure call *\/ */ -/* return analyze_app(obj, bc, i, e, params, fv, sv, d, tailp); */ -/* } */ -/* } else if (sexp_pairp(sexp_car(obj))) { */ -/* #if USE_FAST_LET */ -/* o2 = env_cell(e, sexp_caar(obj)); */ -/* if (o2 */ -/* && sexp_corep(sexp_cdr(o2)) */ -/* && (sexp_core_code(o2) == CORE_LAMBDA) */ -/* && sexp_listp(sexp_cadr(sexp_car(obj)))) { */ -/* /\* let *\/ */ -/* tmp1 = sexp_unbox_integer(sexp_length(sexp_cadar(obj))); */ -/* /\* push params as local stack variables *\/ */ -/* for (o2=sexp_reverse(sexp_cdr(obj)); sexp_pairp(o2); o2=sexp_cdr(o2)) { */ -/* exn = analyze(sexp_car(o2), bc, i, e, params, fv, sv, d, 0); */ -/* if (sexp_exceptionp(exn)) return exn; */ -/* } */ -/* /\* analyze the body in a new local env *\/ */ -/* e2 = extend_env(e, sexp_cadar(obj), (*d)+(tmp1-1)); */ -/* params = sexp_append(sexp_cadar(obj), params); */ -/* exn = */ -/* analyze_sequence(sexp_cddar(obj), bc, i, e, params, fv, sv, d, tailp); */ -/* if (sexp_exceptionp(exn)) return exn; */ -/* /\* set the result and pop off the local vars *\/ */ -/* emit(bc, i, OP_STACK_SET); */ -/* emit_word(bc, i, tmp1+1); */ -/* (*d) -= (tmp1-1); */ -/* for ( ; tmp1>0; tmp1--) */ -/* emit(bc, i, OP_DROP); */ -/* } else */ -/* #endif */ -/* /\* computed application *\/ */ -/* return analyze_app(obj, bc, i, e, params, fv, sv, d, tailp); */ -/* } else { */ -/* return sexp_compile_error("invalid operator", sexp_list1(sexp_car(obj))); */ -/* } */ -/* } else if (sexp_symbolp(obj)) { */ -/* analyze_var_ref(obj, bc, i, e, params, fv, sv, d); */ -/* } else { /\* literal *\/ */ -/* emit_push(bc, i, obj); */ -/* (*d)++; */ -/* } */ -/* return SEXP_TRUE; */ -/* } */ - -/* sexp analyze_sequence (sexp ls, sexp *bc, sexp_uint_t *i, sexp e, */ -/* sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp) */ -/* { */ -/* sexp exn; */ -/* for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) { */ -/* if (sexp_pairp(sexp_cdr(ls))) { */ -/* exn = analyze(sexp_car(ls), bc, i, e, params, fv, sv, d, 0); */ -/* if (sexp_exceptionp(exn)) */ -/* return exn; */ -/* emit(bc, i, OP_DROP); */ -/* (*d)--; */ -/* } else { */ -/* analyze(sexp_car(ls), bc, i, e, params, fv, sv, d, tailp); */ -/* } */ -/* } */ -/* return SEXP_TRUE; */ -/* } */ - -/* sexp analyze_opcode (sexp op, sexp obj, sexp *bc, sexp_uint_t *i, sexp e, */ -/* sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp) */ -/* { */ -/* sexp ls, exn; */ -/* int j, len = sexp_unbox_integer(sexp_length(sexp_cdr(obj))); */ - -/* /\* verify parameters *\/ */ -/* if (len < sexp_opcode_num_args(op)) { */ -/* return sexp_compile_error("not enough arguments", sexp_list1(obj)); */ -/* } else if (len > sexp_opcode_num_args(op)) { */ -/* if (! sexp_opcode_variadic_p(op)) */ -/* return sexp_compile_error("too many arguments", sexp_list1(obj)); */ -/* } else if (sexp_opcode_variadic_p(op) && sexp_opcode_data(op)) { */ -/* emit(bc, i, OP_PARAMETER); */ -/* emit_word(bc, i, (sexp_uint_t) sexp_opcode_data(op)); */ -/* if (! sexp_opcode_opt_param_p(op)) { */ -/* emit(bc, i, OP_CALL); */ -/* emit_word(bc, i, (sexp_uint_t) sexp_make_integer(0)); */ -/* } */ -/* (*d)++; */ -/* len++; */ -/* } */ - -/* /\* push arguments *\/ */ -/* for (ls=sexp_reverse(sexp_cdr(obj)); sexp_pairp(ls); ls=sexp_cdr(ls)) { */ -/* exn = analyze(sexp_car(ls), bc, i, e, params, fv, sv, d, 0); */ -/* if (sexp_exceptionp(exn)) return exn; */ -/* } */ - -/* /\* emit operator *\/ */ -/* if (sexp_opcode_class(op) == OPC_ARITHMETIC_INV) { */ -/* emit(bc, i, (len == 1) ? sexp_opcode_inverse(op) : sexp_opcode_code(op)); */ -/* } else { */ -/* if (sexp_opcode_class(op) == OPC_FOREIGN) */ -/* emit_push(bc, i, sexp_opcode_data(op)); */ -/* else if ((len > 2) && sexp_opcode_class(op) == OPC_ARITHMETIC_CMP) { */ -/* emit(bc, i, OP_STACK_REF); */ -/* emit_word(bc, i, 2); */ -/* } */ -/* emit(bc, i, sexp_opcode_inverse(op) ? sexp_opcode_inverse(op) */ -/* : sexp_opcode_code(op)); */ -/* } */ - -/* /\* emit optional folding of operator *\/ */ -/* if (len > 2) { */ -/* if (sexp_opcode_class(op) == OPC_ARITHMETIC */ -/* || sexp_opcode_class(op) == OPC_ARITHMETIC_INV) { */ -/* for (j=len-2; j>0; j--) */ -/* emit(bc, i, sexp_opcode_code(op)); */ -/* } else if (sexp_opcode_class(op) == OPC_ARITHMETIC_CMP) { */ -/* for (j=len-2; j>0; j--) { */ -/* /\* emit(bc, i, OP_JUMP_UNLESS); *\/ */ -/* emit(bc, i, sexp_opcode_code(op)); */ -/* } */ -/* } */ -/* } */ - -/* if (sexp_opcode_class(op) == OPC_PARAMETER) */ -/* emit_word(bc, i, (sexp_uint_t) sexp_opcode_data(op)); */ - -/* (*d) -= (len-1); */ - -/* return SEXP_TRUE; */ -/* } */ - -/* void analyze_var_ref (sexp obj, sexp *bc, sexp_uint_t *i, sexp e, */ -/* sexp params, sexp fv, sexp sv, sexp_uint_t *d) { */ -/* int tmp; */ -/* sexp cell; */ -/* if ((tmp = sexp_list_index(params, obj)) >= 0) { */ -/* cell = env_cell(e, obj); */ -/* emit(bc, i, OP_STACK_REF); */ -/* emit_word(bc, i, *d - sexp_unbox_integer(sexp_cdr(cell))); */ -/* } else if ((tmp = sexp_list_index(fv, obj)) >= 0) { */ -/* emit(bc, i, OP_CLOSURE_REF); */ -/* emit_word(bc, i, (sexp_uint_t) sexp_make_integer(tmp)); */ -/* } else { */ -/* cell = env_cell_create(e, obj); */ -/* emit_push(bc, i, cell); */ -/* emit(bc, i, OP_CDR); */ -/* } */ -/* (*d)++; */ -/* if (sexp_list_index(sv, obj) >= 0) { */ -/* emit(bc, i, OP_CAR); */ -/* } */ -/* } */ - -/* sexp analyze_app (sexp obj, sexp *bc, sexp_uint_t *i, sexp e, */ -/* sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp) { */ -/* sexp o1, exn; */ -/* sexp_uint_t len = sexp_unbox_integer(sexp_length(sexp_cdr(obj))); */ - -/* /\* push the arguments onto the stack *\/ */ -/* for (o1 = sexp_reverse(sexp_cdr(obj)); sexp_pairp(o1); o1 = sexp_cdr(o1)) { */ -/* exn = analyze(sexp_car(o1), bc, i, e, params, fv, sv, d, 0); */ -/* if (sexp_exceptionp(exn)) return exn; */ -/* } */ - -/* /\* push the operator onto the stack *\/ */ -/* exn = analyze(sexp_car(obj), bc, i, e, params, fv, sv, d, 0); */ -/* if (sexp_exceptionp(exn)) return exn; */ - -/* /\* maybe overwrite the current frame *\/ */ -/* if (tailp) { */ -/* emit(bc, i, OP_TAIL_CALL); */ -/* emit_word(bc, i, (sexp_uint_t) sexp_make_integer(sexp_unbox_integer(sexp_length(params))+(*d)+3)); */ -/* emit_word(bc, i, (sexp_uint_t) sexp_make_integer(len)); */ -/* } else { */ -/* /\* normal call *\/ */ -/* emit(bc, i, OP_CALL); */ -/* emit_word(bc, i, (sexp_uint_t) sexp_make_integer(len)); */ -/* } */ - -/* (*d) -= (len); */ -/* return SEXP_TRUE; */ -/* } */ - -/* sexp free_vars (sexp e, sexp formals, sexp obj, sexp fv) { */ -/* sexp o1; */ -/* if (sexp_symbolp(obj)) { */ -/* if (env_global_p(e, obj) */ -/* || (sexp_list_index(formals, obj) >= 0) */ -/* || (sexp_list_index(fv, obj) >= 0)) */ -/* return fv; */ -/* else */ -/* return sexp_cons(obj, fv); */ -/* } else if (sexp_pairp(obj)) { */ -/* if (sexp_symbolp(sexp_car(obj))) { */ -/* if ((o1 = env_cell(e, sexp_car(obj))) */ -/* && sexp_corep(o1) */ -/* && (sexp_core_code(sexp_cdr(o1)) == CORE_LAMBDA)) { */ -/* return free_vars(e, sexp_cadr(obj), sexp_caddr(obj), fv); */ -/* } */ -/* } */ -/* while (sexp_pairp(obj)) { */ -/* fv = free_vars(e, formals, sexp_car(obj), fv); */ -/* obj = sexp_cdr(obj); */ -/* } */ -/* return fv; */ -/* } else { */ -/* return fv; */ -/* } */ -/* } */ - sexp insert_free_var (sexp x, sexp fv) { sexp name=sexp_ref_name(x), loc=sexp_ref_loc(x), ls; for (ls=fv; sexp_pairp(ls); ls=sexp_cdr(ls)) @@ -992,11 +660,22 @@ sexp union_free_vars (sexp fv1, sexp fv2) { return fv2; } +sexp diff_free_vars (sexp fv, sexp params) { + sexp res = SEXP_NULL; + /* sexp_debug("diff-free-vars: ", fv); */ + /* sexp_debug("params: ", params); */ + for ( ; sexp_pairp(fv); fv=sexp_cdr(fv)) + if (sexp_list_index(params, sexp_ref_name(sexp_car(fv))) < 0) + sexp_push(res, sexp_car(fv)); + /* sexp_debug(" => ", res); */ + return res; +} + sexp free_vars (sexp x, sexp fv) { sexp fv1, fv2; if (sexp_lambdap(x)) { fv1 = free_vars(sexp_lambda_body(x), SEXP_NULL); - fv2 = sexp_lset_diff(fv1, sexp_flatten_dot(sexp_lambda_params(x))); + fv2 = diff_free_vars(fv1, sexp_flatten_dot(sexp_lambda_params(x))); sexp_lambda_fv(x) = fv2; fv = union_free_vars(fv2, fv); } else if (sexp_pairp(x)) { @@ -1018,80 +697,6 @@ sexp free_vars (sexp x, sexp fv) { return fv; } -/* sexp set_vars (sexp e, sexp formals, sexp obj, sexp sv) { */ -/* sexp cell; */ -/* int code; */ -/* if (sexp_nullp(formals)) */ -/* return sv; */ -/* if (sexp_pairp(obj)) { */ -/* if (sexp_symbolp(sexp_car(obj))) { */ -/* if ((cell = env_cell(e, sexp_car(obj))) && sexp_corep(sexp_cdr(cell))) { */ -/* code = sexp_core_code(sexp_cdr(cell)); */ -/* if (code == CORE_LAMBDA) { */ -/* formals = sexp_lset_diff(formals, sexp_cadr(obj)); */ -/* return set_vars(e, formals, sexp_caddr(obj), sv); */ -/* } else if ((code == CORE_SET || code == CORE_DEFINE) */ -/* && (sexp_list_index(formals, sexp_cadr(obj)) >= 0) */ -/* && ! (sexp_list_index(sv, sexp_cadr(obj)) >= 0)) { */ -/* sv = sexp_cons(sexp_cadr(obj), sv); */ -/* return set_vars(e, formals, sexp_caddr(obj), sv); */ -/* } */ -/* } */ -/* } */ -/* while (sexp_pairp(obj)) { */ -/* sv = set_vars(e, formals, sexp_car(obj), sv); */ -/* obj = sexp_cdr(obj); */ -/* } */ -/* } */ -/* return sv; */ -/* } */ - -/* sexp analyze_lambda (sexp name, sexp formals, sexp body, */ -/* sexp *bc, sexp_uint_t *i, sexp e, */ -/* sexp params, sexp fv, sexp sv, sexp_uint_t *d, */ -/* int tailp) { */ -/* sexp obj, ls, flat_formals, fv2, e2; */ -/* int k; */ -/* flat_formals = sexp_flatten_dot(formals); */ -/* fv2 = free_vars(e, flat_formals, body, SEXP_NULL); */ -/* e2 = extend_env(e, flat_formals, -4); */ -/* /\* compile the body with respect to the new params *\/ */ -/* obj = compile(flat_formals, body, e2, fv2, sv, 0); */ -/* if (sexp_exceptionp(obj)) return obj; */ -/* if (sexp_nullp(fv2)) { */ -/* /\* no variables to close over, fixed procedure *\/ */ -/* emit_push(bc, i, */ -/* sexp_make_procedure(sexp_make_integer((sexp_listp(formals) */ -/* ? 0 : 1)), */ -/* sexp_length(formals), */ -/* obj, */ -/* sexp_make_vector(sexp_make_integer(0), */ -/* SEXP_UNDEF))); */ -/* (*d)++; */ -/* } else { */ -/* /\* push the closed vars *\/ */ -/* emit_push(bc, i, SEXP_UNDEF); */ -/* emit_push(bc, i, sexp_length(fv2)); */ -/* emit(bc, i, OP_MAKE_VECTOR); */ -/* (*d)++; */ -/* for (ls=fv2, k=0; sexp_pairp(ls); ls=sexp_cdr(ls), k++) { */ -/* analyze_var_ref(sexp_car(ls), bc, i, e, params, fv, SEXP_NULL, d); */ -/* emit_push(bc, i, sexp_make_integer(k)); */ -/* emit(bc, i, OP_STACK_REF); */ -/* emit_word(bc, i, 3); */ -/* emit(bc, i, OP_VECTOR_SET); */ -/* emit(bc, i, OP_DROP); */ -/* (*d)--; */ -/* } */ -/* /\* push the additional procedure info and make the closure *\/ */ -/* emit_push(bc, i, obj); */ -/* emit_push(bc, i, sexp_length(formals)); */ -/* emit_push(bc, i, sexp_make_integer(sexp_listp(formals) ? 0 : 1)); */ -/* emit(bc, i, OP_MAKE_PROCEDURE); */ -/* } */ -/* return SEXP_TRUE; */ -/* } */ - sexp make_param_list(sexp_uint_t i) { sexp res = SEXP_NULL; char sym[2]="a"; @@ -1123,74 +728,6 @@ sexp make_opcode_procedure(sexp op, sexp_uint_t i, sexp e) { return SEXP_UNDEF; } -/* sexp compile(sexp params, sexp obj, sexp e, sexp fv, sexp sv, int done_p) { */ -/* sexp_uint_t i=0, j=0, d=0, define_ok=1, core; */ -/* sexp bc = sexp_alloc_tagged(sexp_sizeof(bytecode)+INIT_BCODE_SIZE, */ -/* SEXP_BYTECODE); */ -/* sexp sv2 = set_vars(e, params, obj, SEXP_NULL), internals=SEXP_NULL, ls; */ -/* sexp_bytecode_length(bc) = INIT_BCODE_SIZE; */ -/* /\* box mutable vars *\/ */ -/* for (ls=params, j=0; sexp_pairp(ls); ls=sexp_cdr(ls), j++) { */ -/* if (sexp_list_index(sv2, sexp_car(ls)) >= 0) { */ -/* emit_push(&bc, &i, SEXP_NULL); */ -/* emit(&bc, &i, OP_STACK_REF); */ -/* emit_word(&bc, &i, j+5); */ -/* emit(&bc, &i, OP_CONS); */ -/* emit(&bc, &i, OP_STACK_SET); */ -/* emit_word(&bc, &i, j+5); */ -/* emit(&bc, &i, OP_DROP); */ -/* } */ -/* } */ -/* sv = sexp_append(sv2, sv); */ -/* /\* determine internal defines *\/ */ -/* if (sexp_env_parent(e)) { */ -/* for (ls=SEXP_NULL; sexp_pairp(obj); obj=sexp_cdr(obj)) { */ -/* core = (sexp_pairp(sexp_car(obj)) && sexp_symbolp(sexp_caar(obj)) */ -/* ? core_code(e, sexp_caar(obj)) : 0); */ -/* if (core == CORE_BEGIN) { */ -/* obj = sexp_cons(sexp_car(obj), */ -/* sexp_append(sexp_cdar(obj), sexp_cdr(obj))); */ -/* } else { */ -/* if (core == CORE_DEFINE) { */ -/* if (! define_ok) */ -/* return sexp_compile_error("definition in non-definition context", */ -/* sexp_list1(obj)); */ -/* internals = sexp_cons(sexp_pairp(sexp_cadar(obj)) */ -/* ? sexp_car(sexp_cadar(obj)) : sexp_cadar(obj), */ -/* internals); */ -/* } else { */ -/* define_ok = 0; */ -/* } */ -/* ls = sexp_cons(sexp_car(obj), ls); */ -/* } */ -/* } */ -/* obj = sexp_reverse(ls); */ -/* j = sexp_unbox_integer(sexp_length(internals)); */ -/* if (sexp_pairp(internals)) { */ -/* e = extend_env(e, internals, d+j); */ -/* /\* XXXX params extended, need to recompute set-vars *\/ */ -/* params = sexp_append(internals, params); */ -/* for (ls=internals; sexp_pairp(ls); ls=sexp_cdr(ls)) */ -/* emit_push(&bc, &i, SEXP_UNDEF); */ -/* d+=j; */ -/* } */ -/* } */ -/* /\* analyze body sequence *\/ */ -/* analyze_sequence(obj, &bc, &i, e, params, fv, sv, &d, */ -/* (! done_p) && (! sexp_pairp(internals))); */ -/* if (sexp_pairp(internals)) { */ -/* emit(&bc, &i, OP_STACK_SET); */ -/* emit_word(&bc, &i, j+1); */ -/* for ( ; j>0; j--) */ -/* emit(&bc, &i, OP_DROP); */ -/* } */ -/* emit(&bc, &i, done_p ? OP_DONE : OP_RET); */ -/* shrink_bcode(&bc, i); */ -/* print_bytecode(bc); */ -/* disasm(bc); */ -/* return bc; */ -/* } */ - /*********************** the virtual machine **************************/ sexp sexp_save_stack(sexp *stack, sexp_uint_t to) { @@ -1227,7 +764,7 @@ sexp vm(sexp bc, sexp cp, sexp e, sexp* stack, sexp_sint_t top) { sexp_sint_t i, j, k, fp=top-4; loop: - print_stack(stack, top); + print_stack(stack, top, fp); fprintf(stderr, "OP: %s (%d)\n", (*ip<=71) ? reverse_opcode_names[*ip] : "", *ip); switch (*ip++) { case OP_NOOP: @@ -1237,14 +774,14 @@ sexp vm(sexp bc, sexp cp, sexp e, sexp* stack, sexp_sint_t top) { /* fprintf(stderr, "STACK-REF[%ld - %ld = %ld]\n", top, */ /* (sexp_sint_t) ((sexp*)ip)[0], top - (sexp_sint_t) ((sexp*)ip)[0]); */ /* stack[top] = stack[top - (sexp_sint_t) ((sexp*)ip)[0]]; */ - stack[top] = stack[fp - (sexp_sint_t) ((sexp*)ip)[0]]; + stack[top] = stack[fp - 1 - (sexp_sint_t) ((sexp*)ip)[0]]; ip += sizeof(sexp); top++; break; case OP_LOCAL_SET: /* fprintf(stderr, "STACK-SET[%ld - %ld = %ld]\n", top, */ /* (sexp_sint_t) ((sexp*)ip)[0], top - (sexp_sint_t) ((sexp*)ip)[0]); */ - stack[fp - (sexp_sint_t) ((sexp*)ip)[0]] = _ARG1; + stack[fp - 1 - (sexp_sint_t) ((sexp*)ip)[0]] = _ARG1; _ARG1 = SEXP_UNDEF; ip += sizeof(sexp); break; diff --git a/sexp.c b/sexp.c index 0519207e..3fa8a7d9 100644 --- a/sexp.c +++ b/sexp.c @@ -186,7 +186,7 @@ sexp sexp_assq (sexp x, sexp ls) { 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) + if (sexp_list_index(b, sexp_car(a)) < 0) res = sexp_cons(sexp_car(a), res); return res; } @@ -478,6 +478,13 @@ void sexp_write (sexp obj, sexp out) { sexp_write_string("#", out); break; case SEXP_MACRO: sexp_write_string("#", out); break; + case SEXP_LAMBDA: + sexp_write_string("#", out); break; + case SEXP_REF: + sexp_write_string("#", out); + break; case SEXP_STRING: sexp_write_char('"', out); i = sexp_string_length(obj); From b49a12e48beb2dcad3a09866aad337a67d5c2e44 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 26 Mar 2009 13:58:42 +0900 Subject: [PATCH 052/154] removing commented out code --- eval.c | 5 ----- 1 file changed, 5 deletions(-) diff --git a/eval.c b/eval.c index 9fb85a8c..69263aa8 100644 --- a/eval.c +++ b/eval.c @@ -771,16 +771,11 @@ sexp vm(sexp bc, sexp cp, sexp e, sexp* stack, sexp_sint_t top) { fprintf(stderr, "noop\n"); break; case OP_LOCAL_REF: -/* fprintf(stderr, "STACK-REF[%ld - %ld = %ld]\n", top, */ -/* (sexp_sint_t) ((sexp*)ip)[0], top - (sexp_sint_t) ((sexp*)ip)[0]); */ - /* stack[top] = stack[top - (sexp_sint_t) ((sexp*)ip)[0]]; */ stack[top] = stack[fp - 1 - (sexp_sint_t) ((sexp*)ip)[0]]; ip += sizeof(sexp); top++; break; case OP_LOCAL_SET: -/* fprintf(stderr, "STACK-SET[%ld - %ld = %ld]\n", top, */ -/* (sexp_sint_t) ((sexp*)ip)[0], top - (sexp_sint_t) ((sexp*)ip)[0]); */ stack[fp - 1 - (sexp_sint_t) ((sexp*)ip)[0]] = _ARG1; _ARG1 = SEXP_UNDEF; ip += sizeof(sexp); From 560cd92ceca467b5ddb7f28a53c1dcf49f23a2fb Mon Sep 17 00:00:00 2001 From: alexander-s Date: Thu, 26 Mar 2009 16:06:26 +0900 Subject: [PATCH 053/154] fixing closures --- eval.c | 43 +++++++++++++++++++++++++++---------------- 1 file changed, 27 insertions(+), 16 deletions(-) diff --git a/eval.c b/eval.c index 69263aa8..25301659 100644 --- a/eval.c +++ b/eval.c @@ -605,33 +605,47 @@ void compile_general_app (sexp app, sexp context) { } void compile_lambda (sexp lambda, sexp context) { - sexp fv, ctx, flags, bc, len, ref, vec, prev_lambda, prev_fv; + sexp fv, ls, ctx, flags, bc, len, ref, vec, prev_lambda, prev_fv; sexp_uint_t k; prev_lambda = sexp_context_lambda(context); prev_fv = sexp_lambdap(prev_lambda) ? sexp_lambda_fv(prev_lambda) : SEXP_NULL; fv = sexp_lambda_fv(lambda); ctx = sexp_new_context(sexp_context_stack(context)); sexp_context_lambda(ctx) = lambda; + /* box mutable vars */ + for (ls=sexp_lambda_sv(lambda); sexp_pairp(ls); ls=sexp_cdr(ls)) { + k = sexp_list_index(sexp_lambda_params(lambda), sexp_car(ls)); + if (k >= 0) { + emit(OP_LOCAL_REF, ctx); + emit_word(k, ctx); + emit_push(sexp_car(ls), ctx); + emit(OP_CONS, ctx); + emit(OP_LOCAL_SET, ctx); + emit_word(k, ctx); + emit(OP_DROP, ctx); + } + } compile_one(sexp_lambda_body(lambda), ctx); flags = sexp_make_integer(sexp_listp(sexp_lambda_params(lambda)) ? 0 : 1); len = sexp_length(sexp_lambda_params(lambda)); bc = finalize_bytecode(ctx); if (sexp_nullp(fv)) { + /* shortcut, no free vars */ vec = sexp_make_vector(sexp_make_integer(0), SEXP_UNDEF); compile_lit(sexp_make_procedure(flags, len, bc, vec), context); } else { /* push the closed vars */ emit_push(SEXP_UNDEF, context); - emit_push(len, context); + emit_push(sexp_length(fv), context); emit(OP_MAKE_VECTOR, context); sexp_context_depth(context)--; for (k=0; sexp_pairp(fv); fv=sexp_cdr(fv), k++) { ref = sexp_car(fv); compile_non_global_ref(sexp_ref_name(ref), sexp_ref_cell(ref), - prev_lambda, prev_fv, context, 1); + prev_lambda, prev_fv, context, 0); emit_push(sexp_make_integer(k), context); emit(OP_LOCAL_REF, context); - emit_word(3, context); + emit_word(-5, context); emit(OP_VECTOR_SET, context); emit(OP_DROP, context); sexp_context_depth(context)--; @@ -647,7 +661,8 @@ void compile_lambda (sexp lambda, sexp context) { sexp insert_free_var (sexp x, sexp fv) { sexp name=sexp_ref_name(x), loc=sexp_ref_loc(x), ls; for (ls=fv; sexp_pairp(ls); ls=sexp_cdr(ls)) - if (name == sexp_caar(ls) && loc == sexp_cdar(ls)) + if ((name == sexp_ref_name(sexp_car(ls))) + && (loc == sexp_ref_loc(sexp_car(ls)))) return fv; return sexp_cons(x, fv); } @@ -662,12 +677,12 @@ sexp union_free_vars (sexp fv1, sexp fv2) { sexp diff_free_vars (sexp fv, sexp params) { sexp res = SEXP_NULL; - /* sexp_debug("diff-free-vars: ", fv); */ - /* sexp_debug("params: ", params); */ +/* sexp_debug("diff-free-vars: ", fv); */ +/* sexp_debug("params: ", params); */ for ( ; sexp_pairp(fv); fv=sexp_cdr(fv)) if (sexp_list_index(params, sexp_ref_name(sexp_car(fv))) < 0) sexp_push(res, sexp_car(fv)); - /* sexp_debug(" => ", res); */ +/* sexp_debug(" => ", res); */ return res; } @@ -785,10 +800,14 @@ sexp vm(sexp bc, sexp cp, sexp e, sexp* stack, sexp_sint_t top) { ip += sizeof(sexp); break; case OP_VECTOR_REF: + if (! sexp_vectorp(_ARG1)) + sexp_raise("vector-ref: not a vector", sexp_list1(_ARG1)); _ARG2 = sexp_vector_ref(_ARG1, _ARG2); top--; break; case OP_VECTOR_SET: + if (! sexp_vectorp(_ARG1)) + sexp_raise("vector-set!: not a vector", sexp_list1(_ARG1)); sexp_vector_set(_ARG1, _ARG2, _ARG3); _ARG3 = SEXP_UNDEF; top-=2; @@ -1136,18 +1155,14 @@ sexp vm(sexp bc, sexp cp, sexp e, sexp* stack, sexp_sint_t top) { _ARG1 = (i == EOF) ? SEXP_EOF : sexp_make_character(i); break; case OP_RET: -/* if (top<4) */ -/* goto end_loop; */ fp = (sexp_sint_t) _ARG2; cp = _ARG3; ip = (unsigned char*) sexp_unbox_integer(_ARG4); i = sexp_unbox_integer(_ARG5); stack[top-i-5] = _ARG1; top = top-i-4; - fprintf(stderr, "returning to %p (i=%ld)\n", ip, i); break; case OP_DONE: - fprintf(stderr, "done!\n"); goto end_loop; default: sexp_raise("unknown opcode", sexp_list1(sexp_make_integer(*(ip-1)))); @@ -1369,12 +1384,8 @@ int main (int argc, char **argv) { sexp_uint_t i, quit=0, init_loaded=0; scheme_init(); -/* stack = (sexp*) sexp_alloc(sizeof(sexp) * INIT_STACK_SIZE); */ env = make_standard_env(); interaction_environment = env; -/* bc = sexp_alloc_tagged(sexp_sizeof(bytecode)+16, SEXP_BYTECODE); */ -/* sexp_bytecode_length(bc) = 16; */ -/* i = 0; */ context = sexp_new_context(NULL); emit_push(SEXP_UNDEF, context); emit(OP_DONE, context); From f655930ce165788e0163071faf605e7157fbeecc Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 26 Mar 2009 16:49:50 +0900 Subject: [PATCH 054/154] fixing jumps --- debug.c | 7 ++----- eval.c | 42 ++++++++++++++++++++++-------------------- init.scm | 42 +++++++++++++++++++++--------------------- 3 files changed, 45 insertions(+), 46 deletions(-) diff --git a/debug.c b/debug.c index 2145e4b4..ecfd9cc1 100644 --- a/debug.c +++ b/debug.c @@ -31,6 +31,8 @@ void disasm (sexp bc) { case OP_LOCAL_SET: case OP_CLOSURE_REF: case OP_PARAMETER: + case OP_JUMP: + case OP_JUMP_UNLESS: fprintf(stderr, "%ld", (long) ((sexp*)ip)[0]); ip += sizeof(sexp); break; @@ -45,11 +47,6 @@ void disasm (sexp bc) { ip += sizeof(sexp); } break; - case OP_JUMP: - case OP_JUMP_UNLESS: - fprintf(stderr, "%d", ip[0]); - ip++; - break; } fprintf(stderr, "\n"); if ((! (opcode == OP_RET) || (opcode == OP_DONE)) diff --git a/eval.c b/eval.c index 25301659..f12ac921 100644 --- a/eval.c +++ b/eval.c @@ -33,8 +33,8 @@ sexp analyze_define (sexp x, sexp env); sexp analyze_var_ref (sexp x, sexp env); sexp analyze_set (sexp x, sexp env); -sexp_uint_t sexp_context_make_label (sexp context); -void sexp_context_patch_label (sexp context, sexp_uint_t label); +sexp_sint_t sexp_context_make_label (sexp context); +void sexp_context_patch_label (sexp context, sexp_sint_t label); void compile_one (sexp x, sexp context); void compile_lit (sexp value, sexp context); void compile_seq (sexp app, sexp context); @@ -336,9 +336,9 @@ sexp analyze_seq (sexp ls, sexp env) { sexp analyze_if (sexp x, sexp env) { sexp test, pass, fail; - analyze_bind(test, sexp_car(x), env); - analyze_bind(pass, sexp_cadr(x), env); - analyze_bind(fail, sexp_pairp(sexp_cddr(x))?sexp_caddr(x):SEXP_UNDEF, env); + analyze_bind(test, sexp_cadr(x), env); + analyze_bind(pass, sexp_caddr(x), env); + analyze_bind(fail, sexp_pairp(sexp_cdddr(x))?sexp_cadddr(x):SEXP_UNDEF, env); return sexp_make_cnd(test, pass, fail); } @@ -386,16 +386,16 @@ sexp analyze_set (sexp x, sexp env) { return sexp_make_set(ref, value); } -sexp_uint_t sexp_context_make_label (sexp context) { - sexp_uint_t label = sexp_context_pos(context); +sexp_sint_t sexp_context_make_label (sexp context) { + sexp_sint_t label = sexp_context_pos(context); sexp_context_pos(context) += sizeof(sexp_uint_t); return label; } -void sexp_context_patch_label (sexp context, sexp_uint_t label) { +void sexp_context_patch_label (sexp context, sexp_sint_t label) { sexp bc = sexp_context_bc(context); - ((sexp_uint_t*) sexp_bytecode_data(bc))[label] - = sexp_context_pos(context)-label; + unsigned char *data = sexp_bytecode_data(bc)+label; + *((sexp_sint_t*)data) = sexp_context_pos(context)-label; } static sexp finalize_bytecode (sexp context) { @@ -452,7 +452,7 @@ void compile_seq (sexp app, sexp context) { } void compile_cnd (sexp cnd, sexp context) { - sexp_uint_t label1, label2; + sexp_sint_t label1, label2; compile_one(sexp_cnd_test(cnd), context); emit(OP_JUMP_UNLESS, context); sexp_context_depth(context)--; @@ -1067,21 +1067,23 @@ sexp vm(sexp bc, sexp cp, sexp e, sexp* stack, sexp_sint_t top) { stack[top] = sexp_make_integer(1); stack[top+1] = sexp_make_integer(ip); stack[top+2] = cp; + stack[top+3] = (sexp) fp; _ARG1 = sexp_make_procedure(sexp_make_integer(0), sexp_make_integer(1), continuation_resumer, - sexp_vector(1, sexp_save_stack(stack, top+3))); + sexp_vector(1, sexp_save_stack(stack, top+4))); top++; ip -= sizeof(sexp); goto make_call; break; case OP_RESUMECC: - tmp1 = _ARG4; + tmp1 = _ARG5; top = sexp_restore_stack(sexp_vector_ref(cp, 0), stack); - cp = _ARG1; - ip = (unsigned char*) sexp_unbox_integer(_ARG2); - i = sexp_unbox_integer(_ARG3); - top -= 3; + fp = (sexp_sint_t) _ARG1; + cp = _ARG2; + ip = (unsigned char*) sexp_unbox_integer(_ARG3); + i = sexp_unbox_integer(_ARG4); + top -= 4; _ARG1 = tmp1; break; case OP_ERROR: @@ -1117,13 +1119,13 @@ sexp vm(sexp bc, sexp cp, sexp e, sexp* stack, sexp_sint_t top) { break; case OP_JUMP_UNLESS: if (stack[--top] == SEXP_FALSE) { - ip += ((sexp_uint_t*)ip)[0]; + ip += ((sexp_sint_t*)ip)[0]; } else { - ip++; + ip += sizeof(sexp_sint_t); } break; case OP_JUMP: - ip += ((sexp_uint_t*)ip)[0]; + ip += ((sexp_sint_t*)ip)[0]; break; case OP_DISPLAY: if (sexp_stringp(_ARG1)) { diff --git a/init.scm b/init.scm index b8877e78..838137d0 100644 --- a/init.scm +++ b/init.scm @@ -76,26 +76,26 @@ ;; syntax -(define-syntax letrec - (lambda (expr use-env mac-env) - (list - (cons 'lambda - (cons '() - (append (map (lambda (x) (cons 'define x)) (cadr expr)) - (cddr expr))))))) +;; (define-syntax letrec +;; (lambda (expr use-env mac-env) +;; (list +;; (cons 'lambda +;; (cons '() +;; (append (map (lambda (x) (cons 'define x)) (cadr expr)) +;; (cddr expr))))))) -(define-syntax let - (lambda (expr use-env mac-env) - (cons (cons 'lambda (cons (map car (cadr expr)) (cddr expr))) - (map cadr (cadr expr))))) +;; (define-syntax let +;; (lambda (expr use-env mac-env) +;; (cons (cons 'lambda (cons (map car (cadr expr)) (cddr expr))) +;; (map cadr (cadr expr))))) -(define-syntax or - (lambda (expr use-env mac-env) - (if (null? (cdr expr)) - #f - (if (null? (cddr expr)) - (cadr expr) - (list 'let (list (list 'tmp (cadr expr))) - (list 'if 'tmp - 'tmp - (cons 'or (cddr expr)))))))) +;; (define-syntax or +;; (lambda (expr use-env mac-env) +;; (if (null? (cdr expr)) +;; #f +;; (if (null? (cddr expr)) +;; (cadr expr) +;; (list 'let (list (list 'tmp (cadr expr))) +;; (list 'if 'tmp +;; 'tmp +;; (cons 'or (cddr expr)))))))) From 084343555bcbdce4cef322389a3fae011ab878cd Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 26 Mar 2009 17:04:54 +0900 Subject: [PATCH 055/154] fixin i/o opcodes --- eval.c | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) diff --git a/eval.c b/eval.c index f12ac921..565f60c0 100644 --- a/eval.c +++ b/eval.c @@ -530,7 +530,7 @@ void compile_opcode_app (sexp app, sexp context) { sexp_sint_t i, num_args = sexp_unbox_integer(sexp_length(sexp_cdr(app))); /* maybe push the default for an optional argument */ - if ((num_args < sexp_opcode_num_args(op)) + if ((num_args == sexp_opcode_num_args(op)) && sexp_opcode_variadic_p(op) && sexp_opcode_data(op)) { emit(OP_PARAMETER, context); emit_word((sexp_uint_t)sexp_opcode_data(op), context); @@ -1044,7 +1044,7 @@ sexp vm(sexp bc, sexp cp, sexp e, sexp* stack, sexp_sint_t top) { _ARG1 = sexp_make_integer(i); stack[top] = sexp_make_integer(ip+sizeof(sexp)); stack[top+1] = cp; - stack[top+2] = (sexp) fp; + stack[top+2] = sexp_make_integer(fp); top+=3; bc = sexp_procedure_code(tmp1); ip = sexp_bytecode_data(bc); @@ -1067,7 +1067,7 @@ sexp vm(sexp bc, sexp cp, sexp e, sexp* stack, sexp_sint_t top) { stack[top] = sexp_make_integer(1); stack[top+1] = sexp_make_integer(ip); stack[top+2] = cp; - stack[top+3] = (sexp) fp; + stack[top+3] = sexp_make_integer(fp); _ARG1 = sexp_make_procedure(sexp_make_integer(0), sexp_make_integer(1), continuation_resumer, @@ -1079,7 +1079,7 @@ sexp vm(sexp bc, sexp cp, sexp e, sexp* stack, sexp_sint_t top) { case OP_RESUMECC: tmp1 = _ARG5; top = sexp_restore_stack(sexp_vector_ref(cp, 0), stack); - fp = (sexp_sint_t) _ARG1; + fp = sexp_unbox_integer(_ARG1); cp = _ARG2; ip = (unsigned char*) sexp_unbox_integer(_ARG3); i = sexp_unbox_integer(_ARG4); @@ -1130,6 +1130,8 @@ sexp vm(sexp bc, sexp cp, sexp e, sexp* stack, sexp_sint_t top) { case OP_DISPLAY: if (sexp_stringp(_ARG1)) { sexp_write_string(sexp_string_data(_ARG1), _ARG2); + _ARG2 = SEXP_UNDEF; + top--; break; } case OP_WRITE: @@ -1139,6 +1141,8 @@ sexp vm(sexp bc, sexp cp, sexp e, sexp* stack, sexp_sint_t top) { break; case OP_WRITE_CHAR: sexp_write_char(sexp_unbox_character(_ARG1), _ARG2); + _ARG2 = SEXP_UNDEF; + top--; break; case OP_NEWLINE: sexp_write_char('\n', _ARG1); @@ -1157,7 +1161,7 @@ sexp vm(sexp bc, sexp cp, sexp e, sexp* stack, sexp_sint_t top) { _ARG1 = (i == EOF) ? SEXP_EOF : sexp_make_character(i); break; case OP_RET: - fp = (sexp_sint_t) _ARG2; + fp = sexp_unbox_integer(_ARG2); cp = _ARG3; ip = (unsigned char*) sexp_unbox_integer(_ARG4); i = sexp_unbox_integer(_ARG5); From efdf5b7861c136c94f0c0786f2ae7e4df02882d2 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 26 Mar 2009 17:18:38 +0900 Subject: [PATCH 056/154] fixing parameter index determination --- eval.c | 25 ++++++++++++++++++++----- 1 file changed, 20 insertions(+), 5 deletions(-) diff --git a/eval.c b/eval.c index 565f60c0..295e34e6 100644 --- a/eval.c +++ b/eval.c @@ -112,6 +112,19 @@ static sexp sexp_flatten_dot (sexp ls) { return sexp_nreverse(sexp_reverse_flatten_dot(ls)); } +static int sexp_param_index (sexp params, sexp name) { + int i=0; + while (sexp_pairp(params)) { + if (sexp_car(params) == name) + return i; + params = sexp_cdr(params); + i++; + } + if (params == name) + return i; + return -1; +} + /************************* bytecode utilities ***************************/ static void shrink_bcode(sexp context, sexp_uint_t i) { @@ -489,7 +502,7 @@ void compile_non_global_ref (sexp name, sexp cell, sexp lambda, sexp fv, /* local ref */ sexp_debug("params: ", sexp_lambda_params(lambda)); emit(OP_LOCAL_REF, context); - emit_word(sexp_list_index(sexp_lambda_params(lambda), name), context); + emit_word(sexp_param_index(sexp_lambda_params(lambda), name), context); } else { /* closure ref */ for (i=0; sexp_pairp(fv); fv=sexp_cdr(fv), i++) @@ -614,7 +627,7 @@ void compile_lambda (sexp lambda, sexp context) { sexp_context_lambda(ctx) = lambda; /* box mutable vars */ for (ls=sexp_lambda_sv(lambda); sexp_pairp(ls); ls=sexp_cdr(ls)) { - k = sexp_list_index(sexp_lambda_params(lambda), sexp_car(ls)); + k = sexp_param_index(sexp_lambda_params(lambda), sexp_car(ls)); if (k >= 0) { emit(OP_LOCAL_REF, ctx); emit_word(k, ctx); @@ -680,7 +693,7 @@ sexp diff_free_vars (sexp fv, sexp params) { /* sexp_debug("diff-free-vars: ", fv); */ /* sexp_debug("params: ", params); */ for ( ; sexp_pairp(fv); fv=sexp_cdr(fv)) - if (sexp_list_index(params, sexp_ref_name(sexp_car(fv))) < 0) + if (sexp_param_index(params, sexp_ref_name(sexp_car(fv))) < 0) sexp_push(res, sexp_car(fv)); /* sexp_debug(" => ", res); */ return res; @@ -690,7 +703,7 @@ sexp free_vars (sexp x, sexp fv) { sexp fv1, fv2; if (sexp_lambdap(x)) { fv1 = free_vars(sexp_lambda_body(x), SEXP_NULL); - fv2 = diff_free_vars(fv1, sexp_flatten_dot(sexp_lambda_params(x))); + fv2 = diff_free_vars(fv1, sexp_lambda_params(x)); sexp_lambda_fv(x) = fv2; fv = union_free_vars(fv2, fv); } else if (sexp_pairp(x)) { @@ -1019,17 +1032,19 @@ sexp vm(sexp bc, sexp cp, sexp e, sexp* stack, sexp_sint_t top) { if (! sexp_procedurep(tmp1)) sexp_raise("non procedure application", sexp_list1(tmp1)); j = i - sexp_unbox_integer(sexp_procedure_num_args(tmp1)); + fprintf(stderr, "arg difference: %ld-%ld = %ld\n", i, sexp_unbox_integer(sexp_procedure_num_args(tmp1)), j); if (j < 0) sexp_raise("not enough args", sexp_list2(tmp1, sexp_make_integer(i))); if (j > 0) { if (sexp_procedure_variadic_p(tmp1)) { + fprintf(stderr, "unrolling args\n"); stack[top-i-1] = sexp_cons(stack[top-i-1], SEXP_NULL); for (k=top-i; k Date: Thu, 26 Mar 2009 17:24:28 +0900 Subject: [PATCH 057/154] fixing quote --- eval.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/eval.c b/eval.c index 295e34e6..5e920301 100644 --- a/eval.c +++ b/eval.c @@ -285,7 +285,7 @@ sexp analyze (sexp x, sexp env) { res = analyze_seq(x, env); break; case CORE_QUOTE: - res = sexp_make_lit(x); + res = sexp_make_lit(sexp_cadr(x)); break; default: res = sexp_compile_error("unknown core form", sexp_list1(op)); From 73c600b4dc30163d56c9f7bf546f61d01e019637 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Fri, 27 Mar 2009 01:06:48 +0900 Subject: [PATCH 058/154] fixing var closing to use constant stack-ref, not negative local-ref which would depend on the current depth --- debug.c | 5 +++-- eval.c | 22 ++++++++++++++++++---- eval.h | 3 +-- 3 files changed, 22 insertions(+), 8 deletions(-) diff --git a/debug.c b/debug.c index ecfd9cc1..a45e2426 100644 --- a/debug.c +++ b/debug.c @@ -6,7 +6,7 @@ static const char* reverse_opcode_names[] = {"NOOP", "TAIL-CALL", "CALL", "APPLY1", "CALLCC", "RESUMECC", "ERROR", "FCALL0", "FCALL1", "FCALL2", "FCALL3", "FCALLN", - "JUMP-UNLESS", "JUMP", "RET", "DONE", "PARAMETER", + "JUMP-UNLESS", "JUMP", "RET", "DONE", "PARAMETER", "STACK-REF", "LOCAL-REF", "LOCAL-SET", "CLOSURE-REF", "VECTOR-REF", "VECTOR-SET", "STRING-REF", "STRING-SET", "MAKE-PROCEDURE", "MAKE-VECTOR", "PUSH", "DROP", "PAIRP", "NULLP", "VECTORP", @@ -27,13 +27,14 @@ void disasm (sexp bc) { fprintf(stderr, " %d ", opcode); } switch (opcode) { + case OP_STACK_REF: case OP_LOCAL_REF: case OP_LOCAL_SET: case OP_CLOSURE_REF: case OP_PARAMETER: case OP_JUMP: case OP_JUMP_UNLESS: - fprintf(stderr, "%ld", (long) ((sexp*)ip)[0]); + fprintf(stderr, "%ld", (sexp_sint_t) ((sexp*)ip)[0]); ip += sizeof(sexp); break; case OP_TAIL_CALL: diff --git a/eval.c b/eval.c index 5e920301..edfe8456 100644 --- a/eval.c +++ b/eval.c @@ -657,8 +657,8 @@ void compile_lambda (sexp lambda, sexp context) { compile_non_global_ref(sexp_ref_name(ref), sexp_ref_cell(ref), prev_lambda, prev_fv, context, 0); emit_push(sexp_make_integer(k), context); - emit(OP_LOCAL_REF, context); - emit_word(-5, context); + emit(OP_STACK_REF, context); + emit_word(3, context); emit(OP_VECTOR_SET, context); emit(OP_DROP, context); sexp_context_depth(context)--; @@ -792,23 +792,34 @@ sexp vm(sexp bc, sexp cp, sexp e, sexp* stack, sexp_sint_t top) { sexp_sint_t i, j, k, fp=top-4; loop: + fprintf(stderr, "\n"); print_stack(stack, top, fp); - fprintf(stderr, "OP: %s (%d)\n", (*ip<=71) ? reverse_opcode_names[*ip] : "", *ip); + /* fprintf(stderr, "OP: %s (%d)\n", (*ip<=71) ? reverse_opcode_names[*ip] : "", *ip); */ + fprintf(stderr, "%s ", (*ip<=71) ? reverse_opcode_names[*ip] : ""); switch (*ip++) { case OP_NOOP: - fprintf(stderr, "noop\n"); + fprintf(stderr, "<<>>\n"); + break; + case OP_STACK_REF: + fprintf(stderr, "%ld - %ld => %ld", top, (sexp_sint_t) ((sexp*)ip)[0], top - (sexp_sint_t) ((sexp*)ip)[0]); + stack[top] = stack[top - (sexp_sint_t) ((sexp*)ip)[0]]; + ip += sizeof(sexp); + top++; break; case OP_LOCAL_REF: + fprintf(stderr, "%ld - 1 - %ld => %ld", fp, (sexp_sint_t) ((sexp*)ip)[0], fp - 1 - (sexp_sint_t) ((sexp*)ip)[0]); stack[top] = stack[fp - 1 - (sexp_sint_t) ((sexp*)ip)[0]]; ip += sizeof(sexp); top++; break; case OP_LOCAL_SET: + fprintf(stderr, "%ld - 1 - %ld => %ld", fp, (sexp_sint_t) ((sexp*)ip)[0], fp - 1 - (sexp_sint_t) ((sexp*)ip)[0]); stack[fp - 1 - (sexp_sint_t) ((sexp*)ip)[0]] = _ARG1; _ARG1 = SEXP_UNDEF; ip += sizeof(sexp); break; case OP_CLOSURE_REF: + fprintf(stderr, "%ld", sexp_unbox_integer(((sexp*)ip)[0])); _PUSH(sexp_vector_ref(cp, ((sexp*)ip)[0])); ip += sizeof(sexp); break; @@ -1016,6 +1027,7 @@ sexp vm(sexp bc, sexp cp, sexp e, sexp* stack, sexp_sint_t top) { top -= (j-i-1); goto make_call; case OP_CALL: + fprintf(stderr, " %ld", sexp_unbox_integer(((sexp*)ip)[0])); if (top >= INIT_STACK_SIZE) sexp_raise("out of stack space", SEXP_NULL); i = sexp_unbox_integer(((sexp*)ip)[0]); @@ -1103,6 +1115,7 @@ sexp vm(sexp bc, sexp cp, sexp e, sexp* stack, sexp_sint_t top) { break; case OP_ERROR: call_error_handler: + fprintf(stderr, "\n"); sexp_print_exception(_ARG1, cur_error_port); tmp1 = sexp_cdr(exception_handler_cell); stack[top] = (sexp) 1; @@ -1184,6 +1197,7 @@ sexp vm(sexp bc, sexp cp, sexp e, sexp* stack, sexp_sint_t top) { top = top-i-4; break; case OP_DONE: + fprintf(stderr, "\n"); goto end_loop; default: sexp_raise("unknown opcode", sexp_list1(sexp_make_integer(*(ip-1)))); diff --git a/eval.h b/eval.h index 3ce55f52..67792eea 100644 --- a/eval.h +++ b/eval.h @@ -70,8 +70,7 @@ enum opcode_names { OP_RET, OP_DONE, OP_PARAMETER, -/* OP_STACK_REF, */ -/* OP_STACK_SET, */ + OP_STACK_REF, OP_LOCAL_REF, OP_LOCAL_SET, OP_CLOSURE_REF, From 7b38289ba2c6b5f92ab45dff386c0baa8132c40c Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Fri, 27 Mar 2009 16:47:20 +0900 Subject: [PATCH 059/154] renaming, removing unused functions --- debug.c | 4 +- eval.c | 121 ++++++++++++++++++++++++++------------------------------ eval.h | 1 + sexp.c | 27 ------------- sexp.h | 5 +-- 5 files changed, 59 insertions(+), 99 deletions(-) diff --git a/debug.c b/debug.c index a45e2426..865728cd 100644 --- a/debug.c +++ b/debug.c @@ -3,8 +3,8 @@ /* BSD-style license: http://synthcode.com/license.txt */ static const char* reverse_opcode_names[] = - {"NOOP", "TAIL-CALL", "CALL", "APPLY1", "CALLCC", "RESUMECC", "ERROR", - "FCALL0", "FCALL1", + {"NOOP", "TAIL-CALL", "CALL", "APPLY1", "CALLCC", "RESUMECC", "EVAL", + "ERROR", "FCALL0", "FCALL1", "FCALL2", "FCALL3", "FCALLN", "JUMP-UNLESS", "JUMP", "RET", "DONE", "PARAMETER", "STACK-REF", "LOCAL-REF", "LOCAL-SET", "CLOSURE-REF", diff --git a/eval.c b/eval.c index edfe8456..1e10dfe8 100644 --- a/eval.c +++ b/eval.c @@ -35,18 +35,18 @@ sexp analyze_set (sexp x, sexp env); sexp_sint_t sexp_context_make_label (sexp context); void sexp_context_patch_label (sexp context, sexp_sint_t label); -void compile_one (sexp x, sexp context); -void compile_lit (sexp value, sexp context); -void compile_seq (sexp app, sexp context); -void compile_cnd (sexp cnd, sexp context); -void compile_ref (sexp ref, sexp context, int unboxp); -void compile_non_global_ref (sexp name, sexp loc, sexp lambda, sexp fv, +void generate (sexp x, sexp context); +void generate_lit (sexp value, sexp context); +void generate_seq (sexp app, sexp context); +void generate_cnd (sexp cnd, sexp context); +void generate_ref (sexp ref, sexp context, int unboxp); +void generate_non_global_ref (sexp name, sexp loc, sexp lambda, sexp fv, sexp context, int unboxp); -void compile_set (sexp set, sexp context); -void compile_app (sexp app, sexp context); -void compile_opcode_app (sexp app, sexp context); -void compile_general_app (sexp app, sexp context); -void compile_lambda (sexp lambda, sexp context); +void generate_set (sexp set, sexp context); +void generate_app (sexp app, sexp context); +void generate_opcode_app (sexp app, sexp context); +void generate_general_app (sexp app, sexp context); +void generate_lambda (sexp lambda, sexp context); /********************** environment utilities ***************************/ @@ -74,16 +74,6 @@ static sexp env_cell_create(sexp e, sexp key, sexp value) { return cell; } -/* static int env_global_p (sexp e, sexp id) { */ -/* while (sexp_env_parent(e)) { */ -/* if (sexp_assq(id, sexp_env_bindings(e)) != SEXP_FALSE) */ -/* return 0; */ -/* else */ -/* e = sexp_env_parent(e); */ -/* } */ -/* return 1; */ -/* } */ - static void env_define(sexp e, sexp key, sexp value) { sexp cell = sexp_assq(key, sexp_env_bindings(e)); if (cell != SEXP_FALSE) @@ -179,12 +169,12 @@ static sexp sexp_make_procedure(sexp flags, sexp num_args, return proc; } -/* static sexp sexp_make_macro (sexp p, sexp e) { */ -/* sexp mac = sexp_alloc_type(macro, SEXP_MACRO); */ -/* sexp_macro_env(mac) = e; */ -/* sexp_macro_proc(mac) = p; */ -/* return mac; */ -/* } */ +static sexp sexp_make_macro (sexp p, sexp e) { + sexp mac = sexp_alloc_type(macro, SEXP_MACRO); + sexp_macro_env(mac) = e; + sexp_macro_proc(mac) = p; + return mac; +} static sexp sexp_make_set(sexp var, sexp value) { sexp res = sexp_alloc_type(set, SEXP_SET); @@ -418,68 +408,68 @@ static sexp finalize_bytecode (sexp context) { return sexp_context_bc(context); } -void compile_one (sexp x, sexp context) { +void generate (sexp x, sexp context) { if (sexp_pointerp(x)) { switch (sexp_pointer_tag(x)) { case SEXP_PAIR: - compile_app(x, context); + generate_app(x, context); break; case SEXP_LAMBDA: - compile_lambda(x, context); + generate_lambda(x, context); break; case SEXP_CND: - compile_cnd(x, context); + generate_cnd(x, context); break; case SEXP_REF: - compile_ref(x, context, 1); + generate_ref(x, context, 1); break; case SEXP_SET: - compile_set(x, context); + generate_set(x, context); break; case SEXP_SEQ: - compile_seq(sexp_seq_ls(x), context); + generate_seq(sexp_seq_ls(x), context); break; case SEXP_LIT: - compile_lit(sexp_lit_value(x), context); + generate_lit(sexp_lit_value(x), context); break; default: - compile_lit(x, context); + generate_lit(x, context); } } else { - compile_lit(x, context); + generate_lit(x, context); } } -void compile_lit (sexp value, sexp context) { +void generate_lit (sexp value, sexp context) { emit_push(value, context); } -void compile_seq (sexp app, sexp context) { +void generate_seq (sexp app, sexp context) { sexp head=app, tail=sexp_cdr(app); for ( ; sexp_pairp(tail); head=tail, tail=sexp_cdr(tail)) { - compile_one(sexp_car(head), context); + generate(sexp_car(head), context); emit(OP_DROP, context); sexp_context_depth(context)--; } - compile_one(sexp_car(head), context); + generate(sexp_car(head), context); } -void compile_cnd (sexp cnd, sexp context) { +void generate_cnd (sexp cnd, sexp context) { sexp_sint_t label1, label2; - compile_one(sexp_cnd_test(cnd), context); + generate(sexp_cnd_test(cnd), context); emit(OP_JUMP_UNLESS, context); sexp_context_depth(context)--; label1 = sexp_context_make_label(context); - compile_one(sexp_cnd_pass(cnd), context); + generate(sexp_cnd_pass(cnd), context); emit(OP_JUMP, context); sexp_context_depth(context)--; label2 = sexp_context_make_label(context); sexp_context_patch_label(context, label1); - compile_one(sexp_cnd_fail(cnd), context); + generate(sexp_cnd_fail(cnd), context); sexp_context_patch_label(context, label2); } -void compile_ref (sexp ref, sexp context, int unboxp) { +void generate_ref (sexp ref, sexp context, int unboxp) { sexp lam; if (! sexp_lambdap(sexp_ref_loc(ref))) { /* global ref */ @@ -488,12 +478,12 @@ void compile_ref (sexp ref, sexp context, int unboxp) { emit(OP_CDR, context); } else { lam = sexp_context_lambda(context); - compile_non_global_ref(sexp_ref_name(ref), sexp_ref_cell(ref), lam, + generate_non_global_ref(sexp_ref_name(ref), sexp_ref_cell(ref), lam, sexp_lambda_fv(lam), context, unboxp); } } -void compile_non_global_ref (sexp name, sexp cell, sexp lambda, sexp fv, +void generate_non_global_ref (sexp name, sexp cell, sexp lambda, sexp fv, sexp context, int unboxp) { sexp_uint_t i; sexp loc = sexp_cdr(cell); @@ -511,34 +501,34 @@ void compile_non_global_ref (sexp name, sexp cell, sexp lambda, sexp fv, emit(OP_CLOSURE_REF, context); emit_word(i, context); } - if (unboxp && (sexp_list_index(sexp_lambda_sv(loc), name) >= 0)) + if (unboxp && (sexp_memq(name, sexp_lambda_sv(loc)) != SEXP_FALSE)) emit(OP_CDR, context); sexp_context_depth(context)++; } -void compile_set (sexp set, sexp context) { +void generate_set (sexp set, sexp context) { sexp ref = sexp_set_var(set); /* compile the value */ - compile_one(sexp_set_value(set), context); + generate(sexp_set_value(set), context); if (! sexp_lambdap(sexp_ref_loc(ref))) { /* global vars are set directly */ emit_push(sexp_ref_cell(ref), context); } else { /* stack or closure mutable vars are boxed */ - compile_ref(ref, context, 0); + generate_ref(ref, context, 0); } emit(OP_SET_CDR, context); sexp_context_depth(context)--; } -void compile_app (sexp app, sexp context) { +void generate_app (sexp app, sexp context) { if (sexp_opcodep(sexp_car(app))) - compile_opcode_app(app, context); + generate_opcode_app(app, context); else - compile_general_app(app, context); + generate_general_app(app, context); } -void compile_opcode_app (sexp app, sexp context) { +void generate_opcode_app (sexp app, sexp context) { sexp ls, op = sexp_car(app); sexp_sint_t i, num_args = sexp_unbox_integer(sexp_length(sexp_cdr(app))); @@ -560,7 +550,7 @@ void compile_opcode_app (sexp app, sexp context) { && ! sexp_opcode_class(op) == OPC_ARITHMETIC_INV) ? sexp_cdr(app) : sexp_reverse(sexp_cdr(app)); for ( ; sexp_pairp(ls); ls = sexp_cdr(ls)) - compile_one(sexp_car(ls), context); + generate(sexp_car(ls), context); /* emit the actual operator call */ if (sexp_opcode_class(op) == OPC_ARITHMETIC_INV) { @@ -592,16 +582,16 @@ void compile_opcode_app (sexp app, sexp context) { sexp_context_depth(context) -= (num_args-1); } -void compile_general_app (sexp app, sexp context) { +void generate_general_app (sexp app, sexp context) { sexp ls; sexp_uint_t len = sexp_unbox_integer(sexp_length(sexp_cdr(app))); /* push the arguments onto the stack */ for (ls = sexp_reverse(sexp_cdr(app)); sexp_pairp(ls); ls = sexp_cdr(ls)) - compile_one(sexp_car(ls), context); + generate(sexp_car(ls), context); /* push the operator onto the stack */ - compile_one(sexp_car(app), context); + generate(sexp_car(app), context); /* maybe overwrite the current frame */ if (sexp_context_tailp(context)) { @@ -617,7 +607,7 @@ void compile_general_app (sexp app, sexp context) { sexp_context_depth(context) -= len; } -void compile_lambda (sexp lambda, sexp context) { +void generate_lambda (sexp lambda, sexp context) { sexp fv, ls, ctx, flags, bc, len, ref, vec, prev_lambda, prev_fv; sexp_uint_t k; prev_lambda = sexp_context_lambda(context); @@ -638,14 +628,14 @@ void compile_lambda (sexp lambda, sexp context) { emit(OP_DROP, ctx); } } - compile_one(sexp_lambda_body(lambda), ctx); + generate(sexp_lambda_body(lambda), ctx); flags = sexp_make_integer(sexp_listp(sexp_lambda_params(lambda)) ? 0 : 1); len = sexp_length(sexp_lambda_params(lambda)); bc = finalize_bytecode(ctx); if (sexp_nullp(fv)) { /* shortcut, no free vars */ vec = sexp_make_vector(sexp_make_integer(0), SEXP_UNDEF); - compile_lit(sexp_make_procedure(flags, len, bc, vec), context); + generate_lit(sexp_make_procedure(flags, len, bc, vec), context); } else { /* push the closed vars */ emit_push(SEXP_UNDEF, context); @@ -654,7 +644,7 @@ void compile_lambda (sexp lambda, sexp context) { sexp_context_depth(context)--; for (k=0; sexp_pairp(fv); fv=sexp_cdr(fv), k++) { ref = sexp_car(fv); - compile_non_global_ref(sexp_ref_name(ref), sexp_ref_cell(ref), + generate_non_global_ref(sexp_ref_name(ref), sexp_ref_cell(ref), prev_lambda, prev_fv, context, 0); emit_push(sexp_make_integer(k), context); emit(OP_STACK_REF, context); @@ -1315,7 +1305,6 @@ _FN1(SEXP_OPORT, "close-output-port", sexp_close_port), _FN1(0, "load", sexp_load), _FN2(0, SEXP_PAIR, "memq", sexp_memq), _FN2(0, SEXP_PAIR, "assq", sexp_assq), -_FN2(SEXP_PAIR, SEXP_PAIR, "diffq", sexp_lset_diff), _PARAM("current-input-port", (sexp)&cur_input_port, SEXP_IPORT), _PARAM("current-output-port", (sexp)&cur_output_port, SEXP_OPORT), _PARAM("current-error-port", (sexp)&cur_error_port, SEXP_OPORT), @@ -1362,7 +1351,7 @@ sexp compile (sexp x, sexp env, sexp context) { analyze_bind(ast, x, env); free_vars(ast, SEXP_NULL); /* should return SEXP_NULL */ ctx = sexp_new_context(sexp_context_stack(context)); - compile_one(ast, ctx); + generate(ast, ctx); return sexp_make_procedure(sexp_make_integer(0), sexp_make_integer(0), finalize_bytecode(ctx), diff --git a/eval.h b/eval.h index 67792eea..d67d3375 100644 --- a/eval.h +++ b/eval.h @@ -59,6 +59,7 @@ enum opcode_names { OP_APPLY1, OP_CALLCC, OP_RESUMECC, + OP_EVAL, OP_ERROR, OP_FCALL0, OP_FCALL1, diff --git a/sexp.c b/sexp.c index 3fa8a7d9..87b4725f 100644 --- a/sexp.c +++ b/sexp.c @@ -154,17 +154,6 @@ int sexp_listp (sexp 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)) @@ -183,22 +172,6 @@ sexp sexp_assq (sexp x, sexp 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)) diff --git a/sexp.h b/sexp.h index 6ca35e0b..3fc39474 100644 --- a/sexp.h +++ b/sexp.h @@ -349,7 +349,7 @@ struct sexp_struct { #define sexp_list4(a, b, c, d) sexp_cons(a, sexp_cons(b, sexp_cons(c, sexp_cons(d, SEXP_NULL)))) #define sexp_push(ls, x) ((ls) = sexp_cons((x), (ls))) -#define sexp_insert(ls, x) ((sexp_list_index((ls), (x)) >= 0) ? (ls) : sexp_push((ls), (x))) +#define sexp_insert(ls, x) ((sexp_memq((x), (ls)) != SEXP_FALSE) ? (ls) : sexp_push((ls), (x))) #define sexp_car(x) ((x)->value.pair.car) #define sexp_cdr(x) ((x)->value.pair.cdr) @@ -400,9 +400,6 @@ void sexp_printf(sexp port, sexp fmt, ...); sexp sexp_alloc_tagged(size_t size, sexp_uint_t tag); sexp sexp_cons(sexp head, sexp tail); int sexp_listp(sexp obj); -int sexp_list_index(sexp ls, sexp elt); -sexp sexp_lset_diff(sexp a, sexp b); -/* sexp sexp_lset_union(sexp a, sexp b); */ sexp sexp_reverse(sexp ls); sexp sexp_nreverse(sexp ls); sexp sexp_append(sexp a, sexp b); From c97ecdb5014e08d8bafc532268ce1f1f83990917 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Fri, 27 Mar 2009 17:18:50 +0900 Subject: [PATCH 060/154] passing context around in analyze functions --- eval.c | 244 +++++++++++++++++++++++++++++---------------------------- eval.h | 2 +- sexp.h | 6 +- 3 files changed, 131 insertions(+), 121 deletions(-) diff --git a/eval.c b/eval.c index 1e10dfe8..60767172 100644 --- a/eval.c +++ b/eval.c @@ -24,29 +24,29 @@ static sexp the_compile_error_symbol; /*************************** prototypes *******************************/ -sexp analyze (sexp x, sexp env); -sexp analyze_lambda (sexp x, sexp env); -sexp analyze_seq (sexp ls, sexp env); -sexp analyze_if (sexp x, sexp env); -sexp analyze_app (sexp x, sexp env); -sexp analyze_define (sexp x, sexp env); -sexp analyze_var_ref (sexp x, sexp env); -sexp analyze_set (sexp x, sexp env); +static sexp analyze (sexp x, sexp context); +static sexp analyze_lambda (sexp x, sexp context); +static sexp analyze_seq (sexp ls, sexp context); +static sexp analyze_if (sexp x, sexp context); +static sexp analyze_app (sexp x, sexp context); +static sexp analyze_define (sexp x, sexp context); +static sexp analyze_var_ref (sexp x, sexp context); +static sexp analyze_set (sexp x, sexp context); -sexp_sint_t sexp_context_make_label (sexp context); -void sexp_context_patch_label (sexp context, sexp_sint_t label); -void generate (sexp x, sexp context); -void generate_lit (sexp value, sexp context); -void generate_seq (sexp app, sexp context); -void generate_cnd (sexp cnd, sexp context); -void generate_ref (sexp ref, sexp context, int unboxp); -void generate_non_global_ref (sexp name, sexp loc, sexp lambda, sexp fv, - sexp context, int unboxp); -void generate_set (sexp set, sexp context); -void generate_app (sexp app, sexp context); -void generate_opcode_app (sexp app, sexp context); -void generate_general_app (sexp app, sexp context); -void generate_lambda (sexp lambda, sexp context); +static sexp_sint_t sexp_context_make_label (sexp context); +static void sexp_context_patch_label (sexp context, sexp_sint_t label); +static void generate (sexp x, sexp context); +static void generate_lit (sexp value, sexp context); +static void generate_seq (sexp app, sexp context); +static void generate_cnd (sexp cnd, sexp context); +static void generate_ref (sexp ref, sexp context, int unboxp); +static void generate_non_global_ref (sexp name, sexp loc, sexp lambda, + sexp fv, sexp context, int unboxp); +static void generate_set (sexp set, sexp context); +static void generate_app (sexp app, sexp context); +static void generate_opcode_app (sexp app, sexp context); +static void generate_general_app (sexp app, sexp context); +static void generate_lambda (sexp lambda, sexp context); /********************** environment utilities ***************************/ @@ -215,12 +215,15 @@ static sexp sexp_new_context(sexp *stack) { sexp_context_stack(res) = stack; sexp_context_depth(res) = 0; sexp_context_pos(res) = 0; + sexp_context_top(res) = 0; return res; } -static sexp sexp_extend_context(sexp context, sexp lambda) { +static sexp sexp_child_context(sexp context, sexp lambda) { sexp ctx = sexp_new_context(sexp_context_stack(context)); sexp_context_lambda(ctx) = lambda; + sexp_context_env(ctx) = sexp_context_env(context); + sexp_context_top(ctx) = sexp_context_top(context); return ctx; } @@ -238,15 +241,15 @@ static sexp sexp_compile_error(char *message, sexp irritants) { irritants, SEXP_FALSE, SEXP_FALSE); } -#define analyze_check_exception(x) do {if (sexp_exceptionp(x)) \ - return (x); \ +#define analyze_check_exception(x) do {if (sexp_exceptionp(x)) \ + return (x); \ } while (0) -#define analyze_bind(var, x, env) do {(var) = analyze(x,env); \ - analyze_check_exception(var); \ +#define analyze_bind(var, x, context) do {(var) = analyze(x,context); \ + analyze_check_exception(var); \ } while (0) -sexp analyze (sexp x, sexp env) { +static sexp analyze (sexp x, sexp context) { sexp op, cell, res; loop: fprintf(stderr, "analyze: "); @@ -254,25 +257,25 @@ sexp analyze (sexp x, sexp env) { fprintf(stderr, "\n"); if (sexp_pairp(x)) { if (sexp_idp(sexp_car(x))) { - cell = env_cell(env, sexp_car(x)); - if (! cell) return analyze_app(x, env); + cell = env_cell(sexp_context_env(context), sexp_car(x)); + if (! cell) return analyze_app(x, context); op = sexp_cdr(cell); if (sexp_corep(op)) { switch (sexp_core_code(op)) { case CORE_DEFINE: - res = analyze_define(x, env); + res = analyze_define(x, context); break; case CORE_SET: - res = analyze_set(x, env); + res = analyze_set(x, context); break; case CORE_LAMBDA: - res = analyze_lambda(x, env); + res = analyze_lambda(x, context); break; case CORE_IF: - res = analyze_if(x, env); + res = analyze_if(x, context); break; case CORE_BEGIN: - res = analyze_seq(x, env); + res = analyze_seq(x, context); break; case CORE_QUOTE: res = sexp_make_lit(sexp_cadr(x)); @@ -282,23 +285,24 @@ sexp analyze (sexp x, sexp env) { break; } } else if (sexp_macrop(op)) { - /* x = expand_macro(op, x, env); */ + /* x = expand_macro(op, x, context); */ /* goto loop; */ res = sexp_compile_error("macros not yet supported", sexp_list1(x)); } else if (sexp_opcodep(op)) { - res = analyze_app(sexp_cdr(x), env); + res = analyze_app(sexp_cdr(x), context); analyze_check_exception(res); sexp_push(res, op); } else { - res = analyze_app(x, env); + res = analyze_app(x, context); } } else { - res = analyze_app(x, env); + res = analyze_app(x, context); } } else if (sexp_symbolp(x)) { - res = analyze_var_ref(x, env); + res = analyze_var_ref(x, context); } else if (sexp_synclop(x)) { - env = sexp_synclo_env(x); + context = sexp_child_context(context, sexp_context_lambda(context)); + sexp_context_env(context) = sexp_synclo_env(x); x = sexp_synclo_expr(x); goto loop; } else { @@ -307,95 +311,98 @@ sexp analyze (sexp x, sexp env) { return res; } -sexp analyze_lambda (sexp x, sexp env) { +static sexp analyze_lambda (sexp x, sexp context) { sexp res, body; /* XXXX verify syntax */ res = sexp_alloc_type(lambda, SEXP_LAMBDA); sexp_lambda_params(res) = sexp_cadr(x); sexp_lambda_fv(res) = SEXP_NULL; sexp_lambda_sv(res) = SEXP_NULL; - env = extend_env(env, sexp_flatten_dot(sexp_lambda_params(res)), res); - sexp_env_lambda(env) = res; - body = analyze_seq(sexp_cddr(x), env); + context = sexp_child_context(context, res); + sexp_context_env(context) + = extend_env(sexp_context_env(context), + sexp_flatten_dot(sexp_lambda_params(res)), + res); + sexp_env_lambda(sexp_context_env(context)) = res; + body = analyze_seq(sexp_cddr(x), context); analyze_check_exception(body); sexp_lambda_body(res) = body; return res; } -sexp analyze_seq (sexp ls, sexp env) { +static sexp analyze_seq (sexp ls, sexp context) { sexp res, tmp; if (sexp_nullp(ls)) res = SEXP_UNDEF; else if (sexp_nullp(sexp_cdr(ls))) - res = analyze(sexp_car(ls), env); + res = analyze(sexp_car(ls), context); else { res = sexp_alloc_type(seq, SEXP_SEQ); - tmp = analyze_app(ls, env); + tmp = analyze_app(ls, context); analyze_check_exception(tmp); sexp_seq_ls(res) = tmp; } return res; } -sexp analyze_if (sexp x, sexp env) { - sexp test, pass, fail; - analyze_bind(test, sexp_cadr(x), env); - analyze_bind(pass, sexp_caddr(x), env); - analyze_bind(fail, sexp_pairp(sexp_cdddr(x))?sexp_cadddr(x):SEXP_UNDEF, env); +static sexp analyze_if (sexp x, sexp context) { + sexp test, pass, fail, fail_expr; + analyze_bind(test, sexp_cadr(x), context); + analyze_bind(pass, sexp_caddr(x), context); + fail_expr = sexp_pairp(sexp_cdddr(x)) ? sexp_cadddr(x) : SEXP_UNDEF; + analyze_bind(fail, fail_expr, context); return sexp_make_cnd(test, pass, fail); } -sexp analyze_app (sexp x, sexp env) { +static sexp analyze_app (sexp x, sexp context) { sexp res=SEXP_NULL, tmp; for ( ; sexp_pairp(x); x=sexp_cdr(x)) { - analyze_bind(tmp, sexp_car(x), env); + analyze_bind(tmp, sexp_car(x), context); sexp_push(res, tmp); } return sexp_nreverse(res); } -sexp analyze_define (sexp x, sexp env) { - sexp ref, name, value; +static sexp analyze_define (sexp x, sexp context) { + sexp ref, name, value, env = sexp_context_env(context); name = (sexp_pairp(sexp_cadr(x)) ? sexp_caadr(x) : sexp_cadr(x)); if (sexp_env_lambda(env) && sexp_lambdap(sexp_env_lambda(env))) sexp_push(sexp_lambda_locals(sexp_env_lambda(env)), name); if (sexp_pairp(sexp_cadr(x))) value = analyze_lambda(sexp_cons(SEXP_UNDEF, sexp_cons(sexp_cdadr(x), sexp_cddr(x))), - env); + context); else - value = analyze(sexp_caddr(x), env); + value = analyze(sexp_caddr(x), context); analyze_check_exception(value); - ref = analyze_var_ref(name, env); + ref = analyze_var_ref(name, context); analyze_check_exception(ref); env_cell_create(env, name, SEXP_DEF); return sexp_make_set(ref, value); } -sexp analyze_var_ref (sexp x, sexp env) { - sexp cell = env_cell_create(env, x, SEXP_UNDEF); - if (! cell) - fprintf(stderr, "can't happen, env_cell_create => NULL\n"); +static sexp analyze_var_ref (sexp x, sexp context) { + sexp cell = env_cell_create(sexp_context_env(context), x, SEXP_UNDEF); return sexp_make_ref(x, cell); } -sexp analyze_set (sexp x, sexp env) { +static sexp analyze_set (sexp x, sexp context) { sexp ref, value; - ref = analyze_var_ref(sexp_cadr(x), env); + ref = analyze_var_ref(sexp_cadr(x), context); if (sexp_lambdap(sexp_ref_loc(ref))) sexp_insert(sexp_lambda_sv(sexp_ref_loc(ref)), sexp_ref_name(ref)); analyze_check_exception(ref); - analyze_bind(value, sexp_caddr(x), env); + analyze_bind(value, sexp_caddr(x), context); return sexp_make_set(ref, value); } -sexp_sint_t sexp_context_make_label (sexp context) { +static sexp_sint_t sexp_context_make_label (sexp context) { sexp_sint_t label = sexp_context_pos(context); sexp_context_pos(context) += sizeof(sexp_uint_t); return label; } -void sexp_context_patch_label (sexp context, sexp_sint_t label) { +static void sexp_context_patch_label (sexp context, sexp_sint_t label) { sexp bc = sexp_context_bc(context); unsigned char *data = sexp_bytecode_data(bc)+label; *((sexp_sint_t*)data) = sexp_context_pos(context)-label; @@ -408,7 +415,7 @@ static sexp finalize_bytecode (sexp context) { return sexp_context_bc(context); } -void generate (sexp x, sexp context) { +static void generate (sexp x, sexp context) { if (sexp_pointerp(x)) { switch (sexp_pointer_tag(x)) { case SEXP_PAIR: @@ -440,11 +447,11 @@ void generate (sexp x, sexp context) { } } -void generate_lit (sexp value, sexp context) { +static void generate_lit (sexp value, sexp context) { emit_push(value, context); } -void generate_seq (sexp app, sexp context) { +static void generate_seq (sexp app, sexp context) { sexp head=app, tail=sexp_cdr(app); for ( ; sexp_pairp(tail); head=tail, tail=sexp_cdr(tail)) { generate(sexp_car(head), context); @@ -454,7 +461,7 @@ void generate_seq (sexp app, sexp context) { generate(sexp_car(head), context); } -void generate_cnd (sexp cnd, sexp context) { +static void generate_cnd (sexp cnd, sexp context) { sexp_sint_t label1, label2; generate(sexp_cnd_test(cnd), context); emit(OP_JUMP_UNLESS, context); @@ -469,7 +476,7 @@ void generate_cnd (sexp cnd, sexp context) { sexp_context_patch_label(context, label2); } -void generate_ref (sexp ref, sexp context, int unboxp) { +static void generate_ref (sexp ref, sexp context, int unboxp) { sexp lam; if (! sexp_lambdap(sexp_ref_loc(ref))) { /* global ref */ @@ -483,8 +490,8 @@ void generate_ref (sexp ref, sexp context, int unboxp) { } } -void generate_non_global_ref (sexp name, sexp cell, sexp lambda, sexp fv, - sexp context, int unboxp) { +static void generate_non_global_ref (sexp name, sexp cell, sexp lambda, + sexp fv, sexp context, int unboxp) { sexp_uint_t i; sexp loc = sexp_cdr(cell); sexp_debug("cell: ", cell); @@ -506,7 +513,7 @@ void generate_non_global_ref (sexp name, sexp cell, sexp lambda, sexp fv, sexp_context_depth(context)++; } -void generate_set (sexp set, sexp context) { +static void generate_set (sexp set, sexp context) { sexp ref = sexp_set_var(set); /* compile the value */ generate(sexp_set_value(set), context); @@ -521,14 +528,14 @@ void generate_set (sexp set, sexp context) { sexp_context_depth(context)--; } -void generate_app (sexp app, sexp context) { +static void generate_app (sexp app, sexp context) { if (sexp_opcodep(sexp_car(app))) generate_opcode_app(app, context); else generate_general_app(app, context); } -void generate_opcode_app (sexp app, sexp context) { +static void generate_opcode_app (sexp app, sexp context) { sexp ls, op = sexp_car(app); sexp_sint_t i, num_args = sexp_unbox_integer(sexp_length(sexp_cdr(app))); @@ -582,7 +589,7 @@ void generate_opcode_app (sexp app, sexp context) { sexp_context_depth(context) -= (num_args-1); } -void generate_general_app (sexp app, sexp context) { +static void generate_general_app (sexp app, sexp context) { sexp ls; sexp_uint_t len = sexp_unbox_integer(sexp_length(sexp_cdr(app))); @@ -607,7 +614,7 @@ void generate_general_app (sexp app, sexp context) { sexp_context_depth(context) -= len; } -void generate_lambda (sexp lambda, sexp context) { +static void generate_lambda (sexp lambda, sexp context) { sexp fv, ls, ctx, flags, bc, len, ref, vec, prev_lambda, prev_fv; sexp_uint_t k; prev_lambda = sexp_context_lambda(context); @@ -661,7 +668,7 @@ void generate_lambda (sexp lambda, sexp context) { } } -sexp insert_free_var (sexp x, sexp fv) { +static sexp insert_free_var (sexp x, sexp fv) { sexp name=sexp_ref_name(x), loc=sexp_ref_loc(x), ls; for (ls=fv; sexp_pairp(ls); ls=sexp_cdr(ls)) if ((name == sexp_ref_name(sexp_car(ls))) @@ -670,7 +677,7 @@ sexp insert_free_var (sexp x, sexp fv) { return sexp_cons(x, fv); } -sexp union_free_vars (sexp fv1, sexp fv2) { +static sexp union_free_vars (sexp fv1, sexp fv2) { if (sexp_nullp(fv2)) return fv1; for ( ; sexp_pairp(fv1); fv1=sexp_cdr(fv1)) @@ -678,7 +685,7 @@ sexp union_free_vars (sexp fv1, sexp fv2) { return fv2; } -sexp diff_free_vars (sexp fv, sexp params) { +static sexp diff_free_vars (sexp fv, sexp params) { sexp res = SEXP_NULL; /* sexp_debug("diff-free-vars: ", fv); */ /* sexp_debug("params: ", params); */ @@ -689,7 +696,7 @@ sexp diff_free_vars (sexp fv, sexp params) { return res; } -sexp free_vars (sexp x, sexp fv) { +static sexp free_vars (sexp x, sexp fv) { sexp fv1, fv2; if (sexp_lambdap(x)) { fv1 = free_vars(sexp_lambda_body(x), SEXP_NULL); @@ -715,7 +722,7 @@ sexp free_vars (sexp x, sexp fv) { return fv; } -sexp make_param_list(sexp_uint_t i) { +static sexp make_param_list(sexp_uint_t i) { sexp res = SEXP_NULL; char sym[2]="a"; for (sym[0]+=i; i>0; i--) { @@ -725,7 +732,7 @@ sexp make_param_list(sexp_uint_t i) { return res; } -sexp make_opcode_procedure(sexp op, sexp_uint_t i, sexp e) { +static sexp make_opcode_procedure(sexp op, sexp_uint_t i, sexp e) { /* sexp bc, params, res; */ /* sexp_uint_t pos=0, d=0; */ /* if (i == sexp_opcode_num_args(op) && sexp_opcode_proc(op)) */ @@ -748,7 +755,7 @@ sexp make_opcode_procedure(sexp op, sexp_uint_t i, sexp e) { /*********************** the virtual machine **************************/ -sexp sexp_save_stack(sexp *stack, sexp_uint_t to) { +static sexp sexp_save_stack(sexp *stack, sexp_uint_t to) { sexp res, *data; sexp_uint_t i; res = sexp_make_vector(sexp_make_integer(to), SEXP_UNDEF); @@ -758,7 +765,7 @@ sexp sexp_save_stack(sexp *stack, sexp_uint_t to) { return res; } -sexp_uint_t sexp_restore_stack(sexp saved, sexp *current) { +static sexp_uint_t sexp_restore_stack(sexp saved, sexp *current) { sexp_uint_t len = sexp_vector_length(saved), i; sexp *from = sexp_vector_data(saved); for (i=0; i ", cur_output_port); @@ -1395,7 +1402,7 @@ void repl (sexp env, sexp context) { obj = sexp_read(cur_input_port); if (obj == SEXP_EOF) break; - res = eval_in_context(obj, env, context); + res = eval_in_context(obj, context); if (res != SEXP_UNDEF) { sexp_write(res, cur_output_port); sexp_write_char('\n', cur_output_port); @@ -1411,6 +1418,7 @@ int main (int argc, char **argv) { env = make_standard_env(); interaction_environment = env; context = sexp_new_context(NULL); + sexp_context_env(context) = env; emit_push(SEXP_UNDEF, context); emit(OP_DONE, context); err_handler = sexp_make_procedure(sexp_make_integer(0), @@ -1431,7 +1439,7 @@ int main (int argc, char **argv) { init_loaded = 1; } obj = sexp_read_from_string(argv[i+1]); - res = eval_in_context(obj, env, context); + res = eval_in_context(obj, context); if (argv[i][1] == 'p') { sexp_write(res, cur_output_port); sexp_write_char('\n', cur_output_port); @@ -1454,7 +1462,7 @@ int main (int argc, char **argv) { for ( ; i < argc; i++) sexp_load(sexp_make_string(argv[i])); else - repl(env, context); + repl(context); } return 0; } diff --git a/eval.h b/eval.h index d67d3375..43d80070 100644 --- a/eval.h +++ b/eval.h @@ -142,7 +142,7 @@ enum opcode_names { /* sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp); */ /* sexp vm(sexp bc, sexp cp, sexp e, sexp* stack, sexp_sint_t top); */ -sexp eval_in_context(sexp expr, sexp env, sexp context); +sexp eval_in_context(sexp expr, sexp context); sexp eval(sexp expr, sexp env); #endif /* ! SEXP_EVAL_H */ diff --git a/sexp.h b/sexp.h index 3fc39474..922391a9 100644 --- a/sexp.h +++ b/sexp.h @@ -153,8 +153,8 @@ struct sexp_struct { } lit; /* compiler state */ struct { - sexp bc, lambda, offsets, *stack; - sexp_uint_t pos, depth, tailp; + sexp bc, lambda, offsets, *stack, env; + sexp_uint_t pos, top, depth, tailp; } context; } value; }; @@ -320,10 +320,12 @@ struct sexp_struct { #define sexp_lit_value(x) ((x)->value.lit.value) +#define sexp_context_env(x) ((x)->value.context.env) #define sexp_context_stack(x) ((x)->value.context.stack) #define sexp_context_depth(x) ((x)->value.context.depth) #define sexp_context_bc(x) ((x)->value.context.bc) #define sexp_context_pos(x) ((x)->value.context.pos) +#define sexp_context_top(x) ((x)->value.context.top) #define sexp_context_lambda(x) ((x)->value.context.lambda) #define sexp_context_offsets(x) ((x)->value.context.offsets) #define sexp_context_tailp(x) ((x)->value.context.tailp) From ca62786e3e2c40ffe75abb3ce5ce9db46ff38651 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Fri, 27 Mar 2009 18:02:41 +0900 Subject: [PATCH 061/154] reintroducing dynamic opcode procedures --- eval.c | 68 ++++++++++++++++++++++++++++++++++---------------------- eval.h | 19 +--------------- init.scm | 8 +++---- 3 files changed, 46 insertions(+), 49 deletions(-) diff --git a/eval.c b/eval.c index 60767172..18730361 100644 --- a/eval.c +++ b/eval.c @@ -32,6 +32,7 @@ static sexp analyze_app (sexp x, sexp context); static sexp analyze_define (sexp x, sexp context); static sexp analyze_var_ref (sexp x, sexp context); static sexp analyze_set (sexp x, sexp context); +static sexp analyze_define_syntax (sexp x, sexp context); static sexp_sint_t sexp_context_make_label (sexp context); static void sexp_context_patch_label (sexp context, sexp_sint_t label); @@ -280,14 +281,18 @@ static sexp analyze (sexp x, sexp context) { case CORE_QUOTE: res = sexp_make_lit(sexp_cadr(x)); break; + case CORE_DEFINE_SYNTAX: + res = analyze_define_syntax(x, context); + break; default: res = sexp_compile_error("unknown core form", sexp_list1(op)); break; } } else if (sexp_macrop(op)) { - /* x = expand_macro(op, x, context); */ - /* goto loop; */ - res = sexp_compile_error("macros not yet supported", sexp_list1(x)); + x = apply(sexp_macro_proc(op), + sexp_list3(x, sexp_context_env(context), sexp_macro_env(op)), + context); + goto loop; } else if (sexp_opcodep(op)) { res = analyze_app(sexp_cdr(x), context); analyze_check_exception(res); @@ -396,6 +401,15 @@ static sexp analyze_set (sexp x, sexp context) { return sexp_make_set(ref, value); } +static sexp analyze_define_syntax (sexp x, sexp context) { + sexp name = sexp_cadr(x), cell, proc; + proc = eval_in_context(sexp_caddr(x), context); + analyze_check_exception(proc); + cell = env_cell_create(sexp_context_env(context), name, SEXP_UNDEF); + sexp_cdr(cell) = sexp_make_macro(proc, sexp_context_env(context)); + return SEXP_UNDEF; +} + static sexp_sint_t sexp_context_make_label (sexp context) { sexp_sint_t label = sexp_context_pos(context); sexp_context_pos(context) += sizeof(sexp_uint_t); @@ -732,25 +746,24 @@ static sexp make_param_list(sexp_uint_t i) { return res; } -static sexp make_opcode_procedure(sexp op, sexp_uint_t i, sexp e) { -/* sexp bc, params, res; */ -/* sexp_uint_t pos=0, d=0; */ -/* if (i == sexp_opcode_num_args(op) && sexp_opcode_proc(op)) */ -/* return sexp_opcode_proc(op); */ -/* bc = sexp_alloc_tagged(sexp_sizeof(bytecode)+INIT_BCODE_SIZE, SEXP_BYTECODE); */ -/* params = make_param_list(i); */ -/* e = extend_env(e, params, SEXP_UNDEF); */ -/* sexp_bytecode_length(bc) = INIT_BCODE_SIZE; */ -/* analyze_opcode(op, sexp_cons(op, params), &bc, &pos, e, params, */ -/* SEXP_NULL, SEXP_NULL, &d, 0); */ -/* emit(&bc, &pos, OP_RET); */ -/* shrink_bcode(&bc, pos); */ -/* /\* disasm(bc); *\/ */ -/* res = sexp_make_procedure(sexp_make_integer(0), sexp_make_integer(i), bc, SEXP_UNDEF); */ -/* if (i == sexp_opcode_num_args(op)) */ -/* sexp_opcode_proc(op) = res; */ -/* return res; */ - return SEXP_UNDEF; +static sexp make_opcode_procedure (sexp op, sexp_uint_t i, sexp env, + sexp *stack, sexp_sint_t top) { + sexp context, params, bc, res; + if (i == sexp_opcode_num_args(op) && sexp_opcode_proc(op)) + return sexp_opcode_proc(op); + params = make_param_list(i); + context = sexp_new_context(stack); + sexp_context_top(context) = top; + sexp_context_env(context) = extend_env(env, params, SEXP_UNDEF); + generate_opcode_app(sexp_cons(op, params), context); + bc = finalize_bytecode(context); + res = sexp_make_procedure(sexp_make_integer(0), + sexp_make_integer(i), + bc, + SEXP_UNDEF); + if (i == sexp_opcode_num_args(op)) + sexp_opcode_proc(op) = res; + return res; } /*********************** the virtual machine **************************/ @@ -1032,7 +1045,7 @@ sexp vm(sexp bc, sexp cp, sexp e, sexp* stack, sexp_sint_t top) { make_call: if (sexp_opcodep(tmp1)) { /* compile non-inlined opcode applications on the fly */ - tmp1 = make_opcode_procedure(tmp1, i, e); + tmp1 = make_opcode_procedure(tmp1, i, e, stack, top); if (sexp_exceptionp(tmp1)) { _ARG1 = tmp1; goto call_error_handler; @@ -1041,7 +1054,7 @@ sexp vm(sexp bc, sexp cp, sexp e, sexp* stack, sexp_sint_t top) { if (! sexp_procedurep(tmp1)) sexp_raise("non procedure application", sexp_list1(tmp1)); j = i - sexp_unbox_integer(sexp_procedure_num_args(tmp1)); - fprintf(stderr, "arg difference: %ld-%ld = %ld\n", i, sexp_unbox_integer(sexp_procedure_num_args(tmp1)), j); + fprintf(stderr, "\narg difference: %ld-%ld = %ld\n", i, sexp_unbox_integer(sexp_procedure_num_args(tmp1)), j); if (j < 0) sexp_raise("not enough args", sexp_list2(tmp1, sexp_make_integer(i))); if (j > 0) { @@ -1338,9 +1351,10 @@ sexp make_standard_env () { /* args ... n ret-ip ret-cp ret-fp */ sexp apply(sexp proc, sexp args, sexp context) { sexp *stack = sexp_context_stack(context), ls; - sexp_sint_t top = sexp_context_top(context); - for (ls=args; sexp_pairp(ls); ls=sexp_cdr(ls)) - stack[top++] = sexp_car(ls); + sexp_sint_t top = sexp_context_top(context), offset; + offset = top + sexp_unbox_integer(sexp_length(args)); + for (ls=args; sexp_pairp(ls); ls=sexp_cdr(ls), top++) + stack[--offset] = sexp_car(ls); stack[top] = sexp_make_integer(top); top++; stack[top++] = sexp_make_integer(sexp_bytecode_data(final_resumer)); diff --git a/eval.h b/eval.h index 43d80070..e42cd467 100644 --- a/eval.h +++ b/eval.h @@ -124,24 +124,7 @@ enum opcode_names { /**************************** prototypes ******************************/ -/* sexp compile(sexp params, sexp obj, sexp e, sexp fv, sexp sv, int done_p); */ - -/* sexp analyze_app(sexp obj, sexp *bc, sexp_uint_t *i, */ -/* sexp e, sexp params, sexp fv, sexp sv, */ -/* sexp_uint_t *d, int tailp); */ -/* sexp analyze_lambda(sexp name, sexp formals, sexp body, */ -/* sexp *bc, sexp_uint_t *i, sexp e, */ -/* sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp); */ -/* void analyze_var_ref(sexp name, sexp *bc, sexp_uint_t *i, sexp e, */ -/* sexp params, sexp fv, sexp sv, sexp_uint_t *d); */ -/* sexp analyze_opcode(sexp op, sexp obj, sexp *bc, sexp_uint_t *i, sexp e, */ -/* sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp); */ -/* sexp analyze(sexp obj, sexp *bc, sexp_uint_t *i, sexp e, */ -/* sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp); */ -/* sexp analyze_sequence(sexp ls, sexp *bc, sexp_uint_t *i, sexp e, */ -/* sexp params, sexp fv, sexp sv, sexp_uint_t *d, int tailp); */ -/* sexp vm(sexp bc, sexp cp, sexp e, sexp* stack, sexp_sint_t top); */ - +sexp apply(sexp proc, sexp args, sexp context); sexp eval_in_context(sexp expr, sexp context); sexp eval(sexp expr, sexp env); diff --git a/init.scm b/init.scm index 838137d0..064d4d38 100644 --- a/init.scm +++ b/init.scm @@ -84,10 +84,10 @@ ;; (append (map (lambda (x) (cons 'define x)) (cadr expr)) ;; (cddr expr))))))) -;; (define-syntax let -;; (lambda (expr use-env mac-env) -;; (cons (cons 'lambda (cons (map car (cadr expr)) (cddr expr))) -;; (map cadr (cadr expr))))) +(define-syntax let + (lambda (expr use-env mac-env) + (cons (cons 'lambda (cons (map car (cadr expr)) (cddr expr))) + (map cadr (cadr expr))))) ;; (define-syntax or ;; (lambda (expr use-env mac-env) From 3557f0acdce580e7f4a5a2d8ed6df67f3416ad53 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Fri, 27 Mar 2009 18:19:57 +0900 Subject: [PATCH 062/154] ok, now 1st-class opcodes should work --- eval.c | 14 +++++++++++--- 1 file changed, 11 insertions(+), 3 deletions(-) diff --git a/eval.c b/eval.c index 18730361..ef126c0c 100644 --- a/eval.c +++ b/eval.c @@ -748,14 +748,22 @@ static sexp make_param_list(sexp_uint_t i) { static sexp make_opcode_procedure (sexp op, sexp_uint_t i, sexp env, sexp *stack, sexp_sint_t top) { - sexp context, params, bc, res; + sexp context, lambda, params, refs, ls, bc, res; if (i == sexp_opcode_num_args(op) && sexp_opcode_proc(op)) return sexp_opcode_proc(op); params = make_param_list(i); context = sexp_new_context(stack); + lambda = sexp_alloc_type(lambda, SEXP_LAMBDA); + sexp_lambda_params(lambda) = params; + sexp_lambda_fv(lambda) = SEXP_NULL; + sexp_lambda_sv(lambda) = SEXP_NULL; + sexp_context_lambda(context) = lambda; sexp_context_top(context) = top; - sexp_context_env(context) = extend_env(env, params, SEXP_UNDEF); - generate_opcode_app(sexp_cons(op, params), context); + env = extend_env(env, params, lambda); + sexp_context_env(context) = env; + for (ls=params, refs=SEXP_NULL; sexp_pairp(ls); ls=sexp_cdr(ls)) + sexp_push(refs, sexp_make_ref(sexp_car(ls), env_cell(env, sexp_car(ls)))); + generate_opcode_app(sexp_cons(op, sexp_reverse(refs)), context); bc = finalize_bytecode(context); res = sexp_make_procedure(sexp_make_integer(0), sexp_make_integer(i), From ac4b35962ac77a6ce614bdbc19b13fb269be8d0d Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Fri, 27 Mar 2009 19:12:48 +0900 Subject: [PATCH 063/154] working on tail calls --- debug.c | 5 ----- eval.c | 7 +++++-- init.scm | 34 +++++++++++++++++----------------- 3 files changed, 22 insertions(+), 24 deletions(-) diff --git a/debug.c b/debug.c index 865728cd..d8e0d32e 100644 --- a/debug.c +++ b/debug.c @@ -42,11 +42,6 @@ void disasm (sexp bc) { case OP_PUSH: sexp_write(((sexp*)ip)[0], cur_error_port); ip += sizeof(sexp); - if (opcode==OP_TAIL_CALL) { - fprintf(stderr, " "); - sexp_write(((sexp*)ip)[0], cur_error_port); - ip += sizeof(sexp); - } break; } fprintf(stderr, "\n"); diff --git a/eval.c b/eval.c index ef126c0c..a67b305a 100644 --- a/eval.c +++ b/eval.c @@ -217,6 +217,7 @@ static sexp sexp_new_context(sexp *stack) { sexp_context_depth(res) = 0; sexp_context_pos(res) = 0; sexp_context_top(res) = 0; + sexp_context_tailp(res) = 1; return res; } @@ -467,11 +468,14 @@ static void generate_lit (sexp value, sexp context) { static void generate_seq (sexp app, sexp context) { sexp head=app, tail=sexp_cdr(app); + sexp_uint_t tailp = sexp_context_tailp(context); + sexp_context_tailp(context) = 0; for ( ; sexp_pairp(tail); head=tail, tail=sexp_cdr(tail)) { generate(sexp_car(head), context); emit(OP_DROP, context); sexp_context_depth(context)--; } + sexp_context_tailp(context) = tailp; generate(sexp_car(head), context); } @@ -617,7 +621,6 @@ static void generate_general_app (sexp app, sexp context) { /* maybe overwrite the current frame */ if (sexp_context_tailp(context)) { emit(OP_TAIL_CALL, context); - emit_word(sexp_context_depth(context), context); emit_word((sexp_uint_t)sexp_make_integer(len), context); } else { /* normal call */ @@ -1033,12 +1036,12 @@ sexp vm(sexp bc, sexp cp, sexp e, sexp* stack, sexp_sint_t top) { /* old-args ... n ret-ip ret-cp new-args ... proc */ /* [================= j ===========================] */ /* [==== i =====] */ - j = sexp_unbox_integer(((sexp*)ip)[0]); /* current depth */ i = sexp_unbox_integer(((sexp*)ip)[1]); /* number of params */ tmp1 = _ARG1; /* procedure to call */ /* save frame info */ ip = ((unsigned char*) sexp_unbox_integer(stack[top-i-3])) - sizeof(sexp); cp = stack[top-i-2]; + fp = stack[top-i-2]; /* copy new args into place */ for (k=0; k Date: Sun, 29 Mar 2009 02:21:59 +0900 Subject: [PATCH 064/154] fixing closures with more than one variable --- debug.c | 3 +- eval.c | 44 ++++++++++--------- ...{test03-closure.res => test02-closure.res} | 0 ...{test03-closure.scm => test02-closure.scm} | 0 .../{test02-callcc.res => test07-callcc.res} | 0 .../{test02-callcc.scm => test07-callcc.scm} | 0 6 files changed, 25 insertions(+), 22 deletions(-) rename tests/{test03-closure.res => test02-closure.res} (100%) rename tests/{test03-closure.scm => test02-closure.scm} (100%) rename tests/{test02-callcc.res => test07-callcc.res} (100%) rename tests/{test02-callcc.scm => test07-callcc.scm} (100%) diff --git a/debug.c b/debug.c index d8e0d32e..d45082b6 100644 --- a/debug.c +++ b/debug.c @@ -45,8 +45,7 @@ void disasm (sexp bc) { break; } fprintf(stderr, "\n"); - if ((! (opcode == OP_RET) || (opcode == OP_DONE)) - && (ip - sexp_bytecode_data(bc) < sexp_bytecode_length(bc))) + if (ip - sexp_bytecode_data(bc) < sexp_bytecode_length(bc)) goto loop; } diff --git a/eval.c b/eval.c index a67b305a..d1c6607b 100644 --- a/eval.c +++ b/eval.c @@ -217,7 +217,7 @@ static sexp sexp_new_context(sexp *stack) { sexp_context_depth(res) = 0; sexp_context_pos(res) = 0; sexp_context_top(res) = 0; - sexp_context_tailp(res) = 1; + sexp_context_tailp(res) = 0; return res; } @@ -480,8 +480,10 @@ static void generate_seq (sexp app, sexp context) { } static void generate_cnd (sexp cnd, sexp context) { - sexp_sint_t label1, label2; + sexp_sint_t label1, label2, tailp=sexp_context_tailp(context); + sexp_context_tailp(context) = 0; generate(sexp_cnd_test(cnd), context); + sexp_context_tailp(context) = tailp; emit(OP_JUMP_UNLESS, context); sexp_context_depth(context)--; label1 = sexp_context_make_label(context); @@ -504,7 +506,7 @@ static void generate_ref (sexp ref, sexp context, int unboxp) { } else { lam = sexp_context_lambda(context); generate_non_global_ref(sexp_ref_name(ref), sexp_ref_cell(ref), lam, - sexp_lambda_fv(lam), context, unboxp); + sexp_lambda_fv(lam), context, unboxp); } } @@ -521,7 +523,8 @@ static void generate_non_global_ref (sexp name, sexp cell, sexp lambda, } else { /* closure ref */ for (i=0; sexp_pairp(fv); fv=sexp_cdr(fv), i++) - if (name == sexp_car(fv) && loc == sexp_cdr(fv)) + if ((name == sexp_ref_name(sexp_car(fv))) + && (loc == sexp_ref_loc(sexp_car(fv)))) break; emit(OP_CLOSURE_REF, context); emit_word(i, context); @@ -669,7 +672,7 @@ static void generate_lambda (sexp lambda, sexp context) { for (k=0; sexp_pairp(fv); fv=sexp_cdr(fv), k++) { ref = sexp_car(fv); generate_non_global_ref(sexp_ref_name(ref), sexp_ref_cell(ref), - prev_lambda, prev_fv, context, 0); + prev_lambda, prev_fv, context, 0); emit_push(sexp_make_integer(k), context); emit(OP_STACK_REF, context); emit_word(3, context); @@ -821,7 +824,7 @@ sexp vm(sexp bc, sexp cp, sexp e, sexp* stack, sexp_sint_t top) { case OP_NOOP: fprintf(stderr, "<<>>\n"); break; - case OP_STACK_REF: + case OP_STACK_REF: /* pick in forth */ fprintf(stderr, "%ld - %ld => %ld", top, (sexp_sint_t) ((sexp*)ip)[0], top - (sexp_sint_t) ((sexp*)ip)[0]); stack[top] = stack[top - (sexp_sint_t) ((sexp*)ip)[0]]; ip += sizeof(sexp); @@ -840,8 +843,8 @@ sexp vm(sexp bc, sexp cp, sexp e, sexp* stack, sexp_sint_t top) { ip += sizeof(sexp); break; case OP_CLOSURE_REF: - fprintf(stderr, "%ld", sexp_unbox_integer(((sexp*)ip)[0])); - _PUSH(sexp_vector_ref(cp, ((sexp*)ip)[0])); + fprintf(stderr, "%ld", (sexp_sint_t) ((sexp*)ip)[0]); + _PUSH(sexp_vector_ref(cp, sexp_make_integer(((sexp*)ip)[0]))); ip += sizeof(sexp); break; case OP_VECTOR_REF: @@ -1041,7 +1044,7 @@ sexp vm(sexp bc, sexp cp, sexp e, sexp* stack, sexp_sint_t top) { /* save frame info */ ip = ((unsigned char*) sexp_unbox_integer(stack[top-i-3])) - sizeof(sexp); cp = stack[top-i-2]; - fp = stack[top-i-2]; + fp = (sexp_sint_t) stack[top-i-2]; /* copy new args into place */ for (k=0; k Date: Sun, 29 Mar 2009 16:24:56 +0900 Subject: [PATCH 065/154] wow, looks like all tests pass... --- .hgignore | 1 - eval.c | 55 +++++++++----- sexp.c | 76 ++++++++++++------- ...mutation.res => test03-nested-closure.res} | 0 tests/test03-nested-closure.scm | 8 ++ tests/test05-internal-define.res | 1 + tests/test05-internal-define.scm | 8 ++ .../{test05-letrec.res => test06-letrec.res} | 0 .../{test05-letrec.scm => test06-letrec.scm} | 0 tests/test07-mutation.res | 1 + ...est06-mutation.scm => test07-mutation.scm} | 0 .../{test07-callcc.res => test08-callcc.res} | 0 .../{test07-callcc.scm => test08-callcc.scm} | 0 13 files changed, 102 insertions(+), 48 deletions(-) rename tests/{test06-mutation.res => test03-nested-closure.res} (100%) create mode 100644 tests/test03-nested-closure.scm create mode 100644 tests/test05-internal-define.res create mode 100644 tests/test05-internal-define.scm rename tests/{test05-letrec.res => test06-letrec.res} (100%) rename tests/{test05-letrec.scm => test06-letrec.scm} (100%) create mode 100644 tests/test07-mutation.res rename tests/{test06-mutation.scm => test07-mutation.scm} (100%) rename tests/{test07-callcc.res => test08-callcc.res} (100%) rename tests/{test07-callcc.scm => test08-callcc.scm} (100%) diff --git a/.hgignore b/.hgignore index dce70adb..51566e20 100644 --- a/.hgignore +++ b/.hgignore @@ -12,7 +12,6 @@ junk* *.tar.bz2 *.log *.err -*.res *.out gc gc6.8 diff --git a/eval.c b/eval.c index d1c6607b..601e3940 100644 --- a/eval.c +++ b/eval.c @@ -103,17 +103,19 @@ static sexp sexp_flatten_dot (sexp ls) { return sexp_nreverse(sexp_reverse_flatten_dot(ls)); } -static int sexp_param_index (sexp params, sexp name) { - int i=0; - while (sexp_pairp(params)) { - if (sexp_car(params) == name) +static int sexp_param_index (sexp lambda, sexp name) { + sexp ls = sexp_lambda_params(lambda); + int i = 0; + for (i=0; sexp_pairp(ls); ls=sexp_cdr(ls), i++) + if (sexp_car(ls) == name) return i; - params = sexp_cdr(params); - i++; - } - if (params == name) + if (ls == name) return i; - return -1; + ls = sexp_lambda_locals(lambda); + for (i=-1; sexp_pairp(ls); ls=sexp_cdr(ls), i--) + if (sexp_car(ls) == name) + return i; + return -10000; } /************************* bytecode utilities ***************************/ @@ -150,8 +152,10 @@ static void emit(char c, sexp context) { } static void emit_word(sexp_uint_t val, sexp context) { + unsigned char *data; expand_bcode(context, sizeof(sexp)); - *((sexp_uint_t*)(&(sexp_bytecode_data(sexp_context_bc(context))[sexp_context_pos(context)]))) = val; + data = sexp_bytecode_data(sexp_context_bc(context)); + *((sexp_uint_t*)(&(data[sexp_context_pos(context)]))) = val; sexp_context_pos(context) += sizeof(sexp); } @@ -324,6 +328,7 @@ static sexp analyze_lambda (sexp x, sexp context) { sexp_lambda_params(res) = sexp_cadr(x); sexp_lambda_fv(res) = SEXP_NULL; sexp_lambda_sv(res) = SEXP_NULL; + sexp_lambda_locals(res) = SEXP_NULL; context = sexp_child_context(context, res); sexp_context_env(context) = extend_env(sexp_context_env(context), @@ -514,12 +519,10 @@ static void generate_non_global_ref (sexp name, sexp cell, sexp lambda, sexp fv, sexp context, int unboxp) { sexp_uint_t i; sexp loc = sexp_cdr(cell); - sexp_debug("cell: ", cell); if (loc == lambda && sexp_lambdap(lambda)) { /* local ref */ - sexp_debug("params: ", sexp_lambda_params(lambda)); emit(OP_LOCAL_REF, context); - emit_word(sexp_param_index(sexp_lambda_params(lambda), name), context); + emit_word(sexp_param_index(lambda, name), context); } else { /* closure ref */ for (i=0; sexp_pairp(fv); fv=sexp_cdr(fv), i++) @@ -642,9 +645,12 @@ static void generate_lambda (sexp lambda, sexp context) { fv = sexp_lambda_fv(lambda); ctx = sexp_new_context(sexp_context_stack(context)); sexp_context_lambda(ctx) = lambda; + /* allocate space for local vars */ + for (ls=sexp_lambda_locals(lambda); sexp_pairp(ls); ls=sexp_cdr(ls)) + emit_push(SEXP_UNDEF, ctx); /* box mutable vars */ for (ls=sexp_lambda_sv(lambda); sexp_pairp(ls); ls=sexp_cdr(ls)) { - k = sexp_param_index(sexp_lambda_params(lambda), sexp_car(ls)); + k = sexp_param_index(lambda, sexp_car(ls)); if (k >= 0) { emit(OP_LOCAL_REF, ctx); emit_word(k, ctx); @@ -710,7 +716,7 @@ static sexp diff_free_vars (sexp fv, sexp params) { /* sexp_debug("diff-free-vars: ", fv); */ /* sexp_debug("params: ", params); */ for ( ; sexp_pairp(fv); fv=sexp_cdr(fv)) - if (sexp_param_index(params, sexp_ref_name(sexp_car(fv))) < 0) + if (sexp_memq(sexp_ref_name(sexp_car(fv)), params) == SEXP_FALSE) sexp_push(res, sexp_car(fv)); /* sexp_debug(" => ", res); */ return res; @@ -720,7 +726,7 @@ static sexp free_vars (sexp x, sexp fv) { sexp fv1, fv2; if (sexp_lambdap(x)) { fv1 = free_vars(sexp_lambda_body(x), SEXP_NULL); - fv2 = diff_free_vars(fv1, sexp_lambda_params(x)); + fv2 = diff_free_vars(fv1, sexp_flatten_dot(sexp_lambda_params(x))); sexp_lambda_fv(x) = fv2; fv = union_free_vars(fv2, fv); } else if (sexp_pairp(x)) { @@ -763,6 +769,7 @@ static sexp make_opcode_procedure (sexp op, sexp_uint_t i, sexp env, sexp_lambda_params(lambda) = params; sexp_lambda_fv(lambda) = SEXP_NULL; sexp_lambda_sv(lambda) = SEXP_NULL; + sexp_lambda_locals(lambda) = SEXP_NULL; sexp_context_lambda(context) = lambda; sexp_context_top(context) = top; env = extend_env(env, params, lambda); @@ -1396,6 +1403,10 @@ sexp compile (sexp x, sexp context) { sexp eval_in_context (sexp obj, sexp context) { sexp thunk = compile(obj, context); + if (sexp_exceptionp(thunk)) { + sexp_print_exception(obj, cur_error_port); + return SEXP_UNDEF; + } return apply(thunk, SEXP_NULL, context); } @@ -1431,10 +1442,14 @@ void repl (sexp context) { obj = sexp_read(cur_input_port); if (obj == SEXP_EOF) break; - res = eval_in_context(obj, context); - if (res != SEXP_UNDEF) { - sexp_write(res, cur_output_port); - sexp_write_char('\n', cur_output_port); + if (sexp_exceptionp(obj)) { + sexp_print_exception(obj, cur_error_port); + } else { + res = eval_in_context(obj, context); + if (res != SEXP_UNDEF) { + sexp_write(res, cur_output_port); + sexp_write_char('\n', cur_output_port); + } } } } diff --git a/sexp.c b/sexp.c index 87b4725f..bd9ef1c1 100644 --- a/sexp.c +++ b/sexp.c @@ -36,7 +36,9 @@ static char sexp_separators[] = { 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 digit_value (c) { + return (((c)<='9') ? ((c) - '0') : ((toupper(c) - 'A') + 10)); +} static int is_separator(int c) { /* return (!((c-9)&(~3))) | (~(c^4)); */ @@ -133,9 +135,12 @@ sexp sexp_print_exception(sexp exn, sexp out) { } static sexp sexp_read_error(char *message, sexp irritants, sexp port) { - return sexp_make_exception(the_read_error_symbol, sexp_make_string(message), + sexp name = (sexp_port_name(port) + ? sexp_make_string(sexp_port_name(port)) : SEXP_FALSE); + return sexp_make_exception(the_read_error_symbol, + sexp_make_string(message), irritants, - sexp_make_string(sexp_port_name(port)), + name, sexp_make_integer(sexp_port_line(port))); } @@ -382,6 +387,7 @@ sexp sexp_get_output_string(sexp port) { sexp sexp_make_input_port(FILE* in) { sexp p = sexp_alloc_type(port, SEXP_IPORT); sexp_port_stream(p) = in; + sexp_port_name(p) = NULL; sexp_port_line(p) = 0; return p; } @@ -389,6 +395,7 @@ sexp sexp_make_input_port(FILE* in) { sexp sexp_make_output_port(FILE* out) { sexp p = sexp_alloc_type(port, SEXP_OPORT); sexp_port_stream(p) = out; + sexp_port_name(p) = NULL; sexp_port_line(p) = 0; return p; } @@ -480,7 +487,12 @@ void sexp_write (sexp obj, sexp out) { } 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)) + if (obj == sexp_make_character(' ')) + sexp_write_string("#\\space", out); + else if (obj == sexp_make_character('\n')) + sexp_write_string("#\\newline", out); + else 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)); @@ -700,49 +712,59 @@ sexp sexp_read_raw (sexp in) { res = sexp_read_number(in, 10); break; case 'x': res = sexp_read_number(in, 16); break; -/* case 'e': */ -/* case 'i': */ + case 'e': + res = sexp_read(in); + if (sexp_flonump(res)) + res = sexp_make_integer((sexp_sint_t)sexp_flonum_value(res)); + break; + case 'i': + res = sexp_read(in); + if (sexp_integerp(res)) + res = sexp_make_flonum(sexp_unbox_integer(res)); + break; case 'f': case 't': c2 = sexp_read_char(in); if (c2 == EOF || is_separator(c2)) { res = (c1 == 't' ? SEXP_TRUE : SEXP_FALSE); + sexp_push_char(c2, in); } else { - return sexp_read_error("invalid syntax #%c%c", - sexp_list2(sexp_make_character(c1), - sexp_make_character(c2)), - in); + res = 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); + str = sexp_read_symbol(in, c1); + if (str[0] == '\0') + res = + sexp_read_error("unexpected end of character literal", SEXP_NULL, in); + if (str[1] == '\0') { 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 if ((c1 == 'x' || c1 == 'X') && + isxdigit(str[0]) && isxdigit(str[1]) && str[2] == '\0') { + res = sexp_make_character(16 * digit_value(c1) + digit_value(str[1])); } 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'); + res = sexp_make_character('\n'); 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); + res = sexp_read_error("unknown character name", + sexp_list1(sexp_make_string(str)), + in); } } + sexp_free(str); break; case '(': sexp_push_char(c1, in); @@ -750,17 +772,17 @@ sexp sexp_read_raw (sexp 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); + res = 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); + res = sexp_read_error("invalid # syntax", + sexp_list1(sexp_make_character(c1)), in); } break; case '.': diff --git a/tests/test06-mutation.res b/tests/test03-nested-closure.res similarity index 100% rename from tests/test06-mutation.res rename to tests/test03-nested-closure.res diff --git a/tests/test03-nested-closure.scm b/tests/test03-nested-closure.scm new file mode 100644 index 00000000..6656bd4e --- /dev/null +++ b/tests/test03-nested-closure.scm @@ -0,0 +1,8 @@ + +((lambda (a b) + ((lambda (c d e) + (write (+ e (* c 1000) (* a 100) (* b 10) d)) + (newline)) + (- a 2) (+ b 2) 10000)) + 3 5) + diff --git a/tests/test05-internal-define.res b/tests/test05-internal-define.res new file mode 100644 index 00000000..4edae4cc --- /dev/null +++ b/tests/test05-internal-define.res @@ -0,0 +1 @@ +1000 1003 diff --git a/tests/test05-internal-define.scm b/tests/test05-internal-define.scm new file mode 100644 index 00000000..a5576a63 --- /dev/null +++ b/tests/test05-internal-define.scm @@ -0,0 +1,8 @@ + +(let ((a 1000)) + (define b (+ a 3)) + (write a) + (display " ") + (write b) + (newline)) + diff --git a/tests/test05-letrec.res b/tests/test06-letrec.res similarity index 100% rename from tests/test05-letrec.res rename to tests/test06-letrec.res diff --git a/tests/test05-letrec.scm b/tests/test06-letrec.scm similarity index 100% rename from tests/test05-letrec.scm rename to tests/test06-letrec.scm diff --git a/tests/test07-mutation.res b/tests/test07-mutation.res new file mode 100644 index 00000000..c97c8394 --- /dev/null +++ b/tests/test07-mutation.res @@ -0,0 +1 @@ +11357 diff --git a/tests/test06-mutation.scm b/tests/test07-mutation.scm similarity index 100% rename from tests/test06-mutation.scm rename to tests/test07-mutation.scm diff --git a/tests/test07-callcc.res b/tests/test08-callcc.res similarity index 100% rename from tests/test07-callcc.res rename to tests/test08-callcc.res diff --git a/tests/test07-callcc.scm b/tests/test08-callcc.scm similarity index 100% rename from tests/test07-callcc.scm rename to tests/test08-callcc.scm From e7f507a5f1c100f1116dd5be3763c07be2fc7ea5 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 29 Mar 2009 18:59:47 +0900 Subject: [PATCH 066/154] tail calls are back --- eval.c | 35 +++++++++++++++++------------------ sexp.h | 2 -- 2 files changed, 17 insertions(+), 20 deletions(-) diff --git a/eval.c b/eval.c index 601e3940..1a5c3bbd 100644 --- a/eval.c +++ b/eval.c @@ -221,7 +221,7 @@ static sexp sexp_new_context(sexp *stack) { sexp_context_depth(res) = 0; sexp_context_pos(res) = 0; sexp_context_top(res) = 0; - sexp_context_tailp(res) = 0; + sexp_context_tailp(res) = 1; return res; } @@ -540,6 +540,7 @@ static void generate_non_global_ref (sexp name, sexp cell, sexp lambda, static void generate_set (sexp set, sexp context) { sexp ref = sexp_set_var(set); /* compile the value */ + sexp_context_tailp(context) = 0; generate(sexp_set_value(set), context); if (! sexp_lambdap(sexp_ref_loc(ref))) { /* global vars are set directly */ @@ -562,6 +563,7 @@ static void generate_app (sexp app, sexp context) { static void generate_opcode_app (sexp app, sexp context) { sexp ls, op = sexp_car(app); sexp_sint_t i, num_args = sexp_unbox_integer(sexp_length(sexp_cdr(app))); + sexp_context_tailp(context) = 0; /* maybe push the default for an optional argument */ if ((num_args == sexp_opcode_num_args(op)) @@ -615,9 +617,11 @@ static void generate_opcode_app (sexp app, sexp context) { static void generate_general_app (sexp app, sexp context) { sexp ls; - sexp_uint_t len = sexp_unbox_integer(sexp_length(sexp_cdr(app))); + sexp_uint_t len = sexp_unbox_integer(sexp_length(sexp_cdr(app))), + tailp = sexp_context_tailp(context); /* push the arguments onto the stack */ + sexp_context_tailp(context) = 0; for (ls = sexp_reverse(sexp_cdr(app)); sexp_pairp(ls); ls = sexp_cdr(ls)) generate(sexp_car(ls), context); @@ -625,14 +629,8 @@ static void generate_general_app (sexp app, sexp context) { generate(sexp_car(app), context); /* maybe overwrite the current frame */ - if (sexp_context_tailp(context)) { - emit(OP_TAIL_CALL, context); - emit_word((sexp_uint_t)sexp_make_integer(len), context); - } else { - /* normal call */ - emit(OP_CALL, context); - emit_word((sexp_uint_t)sexp_make_integer(len), context); - } + emit((tailp ? OP_TAIL_CALL : OP_CALL), context); + emit_word((sexp_uint_t)sexp_make_integer(len), context); sexp_context_depth(context) -= len; } @@ -1044,18 +1042,18 @@ sexp vm(sexp bc, sexp cp, sexp e, sexp* stack, sexp_sint_t top) { break; case OP_TAIL_CALL: /* old-args ... n ret-ip ret-cp new-args ... proc */ - /* [================= j ===========================] */ /* [==== i =====] */ - i = sexp_unbox_integer(((sexp*)ip)[1]); /* number of params */ - tmp1 = _ARG1; /* procedure to call */ + i = sexp_unbox_integer(((sexp*)ip)[0]); /* number of params */ + tmp1 = _ARG1; /* procedure to call */ /* save frame info */ - ip = ((unsigned char*) sexp_unbox_integer(stack[top-i-3])) - sizeof(sexp); - cp = stack[top-i-2]; - fp = (sexp_sint_t) stack[top-i-2]; + j = sexp_unbox_integer(stack[fp]); + ip = ((unsigned char*) sexp_unbox_integer(stack[fp+1])) - sizeof(sexp); + cp = stack[fp+2]; /* copy new args into place */ for (k=0; km - (char*)0)) */ - #define sexp_sizeof(x) (offsetof(struct sexp_struct, value) \ + sizeof(((sexp)0)->value.x)) From f3d61e88aa93c1dda1a268fde13101c46a4109ee Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 29 Mar 2009 19:32:15 +0900 Subject: [PATCH 067/154] minor cleanup, ordering vm switch statement --- debug.c | 21 +-- eval.c | 354 +++++++++++++++++++--------------------- eval.h | 23 ++- init.scm | 10 +- tests/test06-letrec.scm | 30 +--- 5 files changed, 204 insertions(+), 234 deletions(-) diff --git a/debug.c b/debug.c index d45082b6..2ce3ee6e 100644 --- a/debug.c +++ b/debug.c @@ -3,18 +3,15 @@ /* BSD-style license: http://synthcode.com/license.txt */ static const char* reverse_opcode_names[] = - {"NOOP", "TAIL-CALL", "CALL", "APPLY1", "CALLCC", "RESUMECC", "EVAL", - "ERROR", "FCALL0", "FCALL1", - "FCALL2", "FCALL3", "FCALLN", - "JUMP-UNLESS", "JUMP", "RET", "DONE", "PARAMETER", "STACK-REF", - "LOCAL-REF", "LOCAL-SET", "CLOSURE-REF", - "VECTOR-REF", "VECTOR-SET", "STRING-REF", "STRING-SET", "MAKE-PROCEDURE", - "MAKE-VECTOR", "PUSH", "DROP", "PAIRP", "NULLP", "VECTORP", - "INTEGERP", "SYMBOLP", "STRINGP", "CHARP", "EOFP", "PROCEDUREP", "IPORTP", - "OPORTP", "CAR", "CDR", "SET-CAR", "SET-CDR", "CONS", "ADD", "SUB", "MUL", - "DIV", "QUOT", "MOD", "NEG", "INV", "LT", "LE", "GT", "GE", "EQN", "EQ", - "DISPLAY", "WRITE", "WRITE-CHAR", "NEWLINE", "FLUSH-OUTPUT", "READ", - "READ-CHAR", + {"NOOP", "ERROR", "RESUMECC", "CALLCC", "APPLY1", "TAIL_CALL", "CALL", + "FCALL0", "FCALL1", "FCALL2", "FCALL3", "EVAL", "JUMP_UNLESS", "JUMP", + "PARAMETER", "PUSH", "DROP", "STACK_REF", "LOCAL_REF", "LOCAL_SET", + "CLOSURE_REF", "VECTOR_REF", "VECTOR_SET", "STRING_REF", "STRING_SET", + "MAKE_PROCEDURE", "MAKE_VECTOR", "PAIRP", "NULLP", "VECTORP", "INTEGERP", + "SYMBOLP", "STRINGP", "CHARP", "EOFP", "PROCEDUREP", "IPORTP", "OPORTP", + "CAR", "CDR", "SET_CAR", "SET_CDR", "CONS", "ADD", "SUB", "MUL", "DIV", + "QUOT", "MOD", "NEG", "INV", "LT", "LE", "EQV", "EQ", "DISPLAY", "WRITE", + "WRITE_CHAR", "NEWLINE", "FLUSH_OUTPUT", "READ", "READ_CHAR", "RET", "DONE", }; void disasm (sexp bc) { diff --git a/eval.c b/eval.c index 1a5c3bbd..2e9c99ff 100644 --- a/eval.c +++ b/eval.c @@ -821,34 +821,177 @@ sexp vm(sexp bc, sexp cp, sexp e, sexp* stack, sexp_sint_t top) { sexp_sint_t i, j, k, fp=top-4; loop: - fprintf(stderr, "\n"); - print_stack(stack, top, fp); - /* fprintf(stderr, "OP: %s (%d)\n", (*ip<=71) ? reverse_opcode_names[*ip] : "", *ip); */ - fprintf(stderr, "%s ", (*ip<=71) ? reverse_opcode_names[*ip] : ""); + /* fprintf(stderr, "%s\n", (*ip<=71)?reverse_opcode_names[*ip]:"UNKNOWN"); */ switch (*ip++) { case OP_NOOP: fprintf(stderr, "<<>>\n"); break; - case OP_STACK_REF: /* pick in forth */ - fprintf(stderr, "%ld - %ld => %ld", top, (sexp_sint_t) ((sexp*)ip)[0], top - (sexp_sint_t) ((sexp*)ip)[0]); + case OP_ERROR: + call_error_handler: + fprintf(stderr, "\n"); + sexp_print_exception(_ARG1, cur_error_port); + tmp1 = sexp_cdr(exception_handler_cell); + stack[top] = (sexp) 1; + stack[top+1] = sexp_make_integer(ip+4); + stack[top+2] = cp; + top+=3; + bc = sexp_procedure_code(tmp1); + ip = sexp_bytecode_data(bc); + cp = sexp_procedure_vars(tmp1); + break; + case OP_RESUMECC: + tmp1 = stack[fp-1]; + top = sexp_restore_stack(sexp_vector_ref(cp, 0), stack); + fp = sexp_unbox_integer(_ARG1); + cp = _ARG2; + ip = (unsigned char*) sexp_unbox_integer(_ARG3); + i = sexp_unbox_integer(_ARG4); + top -= 4; + _ARG1 = tmp1; + break; + case OP_CALLCC: + tmp1 = _ARG1; + i = 1; + stack[top] = sexp_make_integer(1); + stack[top+1] = sexp_make_integer(ip); + stack[top+2] = cp; + stack[top+3] = sexp_make_integer(fp); + tmp2 = sexp_vector(1, sexp_save_stack(stack, top+4)); + _ARG1 = sexp_make_procedure(sexp_make_integer(0), + sexp_make_integer(1), + continuation_resumer, + tmp2); + top++; + ip -= sizeof(sexp); + goto make_call; + break; + case OP_APPLY1: + tmp1 = _ARG1; + tmp2 = _ARG2; + i = sexp_unbox_integer(sexp_length(tmp2)); + top += (i-2); + for ( ; sexp_pairp(tmp2); tmp2=sexp_cdr(tmp2), top--) + _ARG1 = sexp_car(tmp2); + top += i+1; + ip -= sizeof(sexp); + goto make_call; + case OP_TAIL_CALL: + i = sexp_unbox_integer(((sexp*)ip)[0]); /* number of params */ + tmp1 = _ARG1; /* procedure to call */ + /* save frame info */ + j = sexp_unbox_integer(stack[fp]); + ip = ((unsigned char*) sexp_unbox_integer(stack[fp+1])) - sizeof(sexp); + cp = stack[fp+2]; + /* copy new args into place */ + for (k=0; k= INIT_STACK_SIZE) + sexp_raise("out of stack space", SEXP_NULL); + i = sexp_unbox_integer(((sexp*)ip)[0]); + tmp1 = _ARG1; + make_call: + if (sexp_opcodep(tmp1)) { + /* compile non-inlined opcode applications on the fly */ + tmp1 = make_opcode_procedure(tmp1, i, e, stack, top); + if (sexp_exceptionp(tmp1)) { + _ARG1 = tmp1; + goto call_error_handler; + } + } + if (! sexp_procedurep(tmp1)) + sexp_raise("non procedure application", sexp_list1(tmp1)); + j = i - sexp_unbox_integer(sexp_procedure_num_args(tmp1)); + if (j < 0) + sexp_raise("not enough args", sexp_list2(tmp1, sexp_make_integer(i))); + if (j > 0) { + if (sexp_procedure_variadic_p(tmp1)) { + stack[top-i-1] = sexp_cons(stack[top-i-1], SEXP_NULL); + for (k=top-i; k=top-i; k--) + stack[k] = stack[k-1]; + stack[top-i-1] = SEXP_NULL; + top++; + i++; + } + _ARG1 = sexp_make_integer(i); + stack[top] = sexp_make_integer(ip+sizeof(sexp)); + stack[top+1] = cp; + stack[top+2] = sexp_make_integer(fp); + top+=3; + bc = sexp_procedure_code(tmp1); + ip = sexp_bytecode_data(bc); + cp = sexp_procedure_vars(tmp1); + fp = top-4; + break; + case OP_FCALL0: + _ARG1 = ((sexp_proc0)_ARG1)(); + if (sexp_exceptionp(_ARG1)) goto call_error_handler; + break; + case OP_FCALL1: + _ARG2 = ((sexp_proc1)_ARG1)(_ARG2); + top--; + if (sexp_exceptionp(_ARG1)) goto call_error_handler; + break; + case OP_FCALL2: + _ARG3 = ((sexp_proc2)_ARG1)(_ARG2, _ARG3); + top-=2; + if (sexp_exceptionp(_ARG1)) goto call_error_handler; + break; + case OP_FCALL3: + _ARG4 =((sexp_proc3)_ARG1)(_ARG2, _ARG3, _ARG4); + top-=3; + if (sexp_exceptionp(_ARG1)) goto call_error_handler; + break; + case OP_JUMP_UNLESS: + if (stack[--top] == SEXP_FALSE) + ip += ((sexp_sint_t*)ip)[0]; + else + ip += sizeof(sexp_sint_t); + break; + case OP_JUMP: + ip += ((sexp_sint_t*)ip)[0]; + break; + case OP_PARAMETER: + _PUSH(*(sexp*)((sexp*)ip)[0]); + ip += sizeof(sexp); + break; + case OP_PUSH: + _PUSH(((sexp*)ip)[0]); + ip += sizeof(sexp); + break; + case OP_DROP: + top--; + break; + case OP_STACK_REF: /* `pick' in forth */ stack[top] = stack[top - (sexp_sint_t) ((sexp*)ip)[0]]; ip += sizeof(sexp); top++; break; case OP_LOCAL_REF: - fprintf(stderr, "%ld - 1 - %ld => %ld", fp, (sexp_sint_t) ((sexp*)ip)[0], fp - 1 - (sexp_sint_t) ((sexp*)ip)[0]); stack[top] = stack[fp - 1 - (sexp_sint_t) ((sexp*)ip)[0]]; ip += sizeof(sexp); top++; break; case OP_LOCAL_SET: - fprintf(stderr, "%ld - 1 - %ld => %ld", fp, (sexp_sint_t) ((sexp*)ip)[0], fp - 1 - (sexp_sint_t) ((sexp*)ip)[0]); stack[fp - 1 - (sexp_sint_t) ((sexp*)ip)[0]] = _ARG1; _ARG1 = SEXP_UNDEF; ip += sizeof(sexp); break; case OP_CLOSURE_REF: - fprintf(stderr, "%ld", (sexp_sint_t) ((sexp*)ip)[0]); _PUSH(sexp_vector_ref(cp, sexp_make_integer(((sexp*)ip)[0]))); ip += sizeof(sexp); break; @@ -882,39 +1025,28 @@ sexp vm(sexp bc, sexp cp, sexp e, sexp* stack, sexp_sint_t top) { _ARG2 = sexp_make_vector(_ARG1, _ARG2); top--; break; - case OP_PUSH: - _PUSH(((sexp*)ip)[0]); - ip += sizeof(sexp); - break; - case OP_DROP: - top--; - break; - case OP_PARAMETER: - _PUSH(*(sexp*)((sexp*)ip)[0]); - ip += sizeof(sexp); - break; case OP_PAIRP: _ARG1 = sexp_make_boolean(sexp_pairp(_ARG1)); break; case OP_NULLP: _ARG1 = sexp_make_boolean(sexp_nullp(_ARG1)); break; - case OP_CHARP: - _ARG1 = sexp_make_boolean(sexp_charp(_ARG1)); break; + case OP_VECTORP: + _ARG1 = sexp_make_boolean(sexp_vectorp(_ARG1)); break; case OP_INTEGERP: _ARG1 = sexp_make_boolean(sexp_integerp(_ARG1)); break; case OP_SYMBOLP: _ARG1 = sexp_make_boolean(sexp_symbolp(_ARG1)); break; case OP_STRINGP: _ARG1 = sexp_make_boolean(sexp_stringp(_ARG1)); break; - case OP_VECTORP: - _ARG1 = sexp_make_boolean(sexp_vectorp(_ARG1)); break; + case OP_CHARP: + _ARG1 = sexp_make_boolean(sexp_charp(_ARG1)); break; + case OP_EOFP: + _ARG1 = sexp_make_boolean(_ARG1 == SEXP_EOF); break; case OP_PROCEDUREP: _ARG1 = sexp_make_boolean(sexp_procedurep(_ARG1)); break; case OP_IPORTP: _ARG1 = sexp_make_boolean(sexp_iportp(_ARG1)); break; case OP_OPORTP: _ARG1 = sexp_make_boolean(sexp_oportp(_ARG1)); break; - case OP_EOFP: - _ARG1 = sexp_make_boolean(_ARG1 == SEXP_EOF); break; case OP_CAR: if (! sexp_pairp(_ARG1)) sexp_raise("car: not a pair", sexp_list1(_ARG1)); _ARG1 = sexp_car(_ARG1); break; @@ -1019,6 +1151,15 @@ sexp vm(sexp bc, sexp cp, sexp e, sexp* stack, sexp_sint_t top) { #endif else sexp_raise("-: not a number", sexp_list1(_ARG1)); break; + case OP_INV: + if (sexp_integerp(_ARG1)) + _ARG1 = sexp_make_flonum(1/(double)sexp_unbox_integer(_ARG1)); +#if USE_FLONUMS + else if (sexp_flonump(_ARG1)) + _ARG1 = sexp_make_flonum(1/sexp_flonum_value(_ARG1)); +#endif + else sexp_raise("/: not a number", sexp_list1(_ARG1)); + break; case OP_LT: _ARG2 = sexp_make_boolean(_ARG1 < _ARG2); top--; @@ -1027,164 +1168,11 @@ sexp vm(sexp bc, sexp cp, sexp e, sexp* stack, sexp_sint_t top) { _ARG2 = sexp_make_boolean(_ARG1 <= _ARG2); top--; break; - case OP_GT: - _ARG2 = sexp_make_boolean(_ARG1 > _ARG2); - top--; - break; - case OP_GE: - _ARG2 = sexp_make_boolean(_ARG1 >= _ARG2); - top--; - break; case OP_EQ: - case OP_EQN: + case OP_EQV: _ARG2 = sexp_make_boolean(_ARG1 == _ARG2); top--; break; - case OP_TAIL_CALL: - /* old-args ... n ret-ip ret-cp new-args ... proc */ - /* [==== i =====] */ - i = sexp_unbox_integer(((sexp*)ip)[0]); /* number of params */ - tmp1 = _ARG1; /* procedure to call */ - /* save frame info */ - j = sexp_unbox_integer(stack[fp]); - ip = ((unsigned char*) sexp_unbox_integer(stack[fp+1])) - sizeof(sexp); - cp = stack[fp+2]; - /* copy new args into place */ - for (k=0; k= INIT_STACK_SIZE) - sexp_raise("out of stack space", SEXP_NULL); - i = sexp_unbox_integer(((sexp*)ip)[0]); - tmp1 = _ARG1; - make_call: - if (sexp_opcodep(tmp1)) { - /* compile non-inlined opcode applications on the fly */ - tmp1 = make_opcode_procedure(tmp1, i, e, stack, top); - if (sexp_exceptionp(tmp1)) { - _ARG1 = tmp1; - goto call_error_handler; - } - } - if (! sexp_procedurep(tmp1)) - sexp_raise("non procedure application", sexp_list1(tmp1)); - j = i - sexp_unbox_integer(sexp_procedure_num_args(tmp1)); - fprintf(stderr, "\narg difference: %ld-%ld = %ld\n", i, sexp_unbox_integer(sexp_procedure_num_args(tmp1)), j); - if (j < 0) - sexp_raise("not enough args", sexp_list2(tmp1, sexp_make_integer(i))); - if (j > 0) { - if (sexp_procedure_variadic_p(tmp1)) { - fprintf(stderr, "unrolling args\n"); - stack[top-i-1] = sexp_cons(stack[top-i-1], SEXP_NULL); - for (k=top-i; k=top-i; k--) - stack[k] = stack[k-1]; - stack[top-i-1] = SEXP_NULL; - top++; - i++; - } - _ARG1 = sexp_make_integer(i); - stack[top] = sexp_make_integer(ip+sizeof(sexp)); - stack[top+1] = cp; - stack[top+2] = sexp_make_integer(fp); - top+=3; - bc = sexp_procedure_code(tmp1); - ip = sexp_bytecode_data(bc); - cp = sexp_procedure_vars(tmp1); - fp = top-4; - break; - case OP_APPLY1: - tmp1 = _ARG1; - tmp2 = _ARG2; - i = sexp_unbox_integer(sexp_length(tmp2)); - top += (i-2); - for ( ; sexp_pairp(tmp2); tmp2=sexp_cdr(tmp2), top--) - _ARG1 = sexp_car(tmp2); - top += i+1; - ip -= sizeof(sexp); - goto make_call; - case OP_CALLCC: - tmp1 = _ARG1; - i = 1; - stack[top] = sexp_make_integer(1); - stack[top+1] = sexp_make_integer(ip); - stack[top+2] = cp; - stack[top+3] = sexp_make_integer(fp); - tmp2 = sexp_vector(1, sexp_save_stack(stack, top+4)); - _ARG1 = sexp_make_procedure(sexp_make_integer(0), - sexp_make_integer(1), - continuation_resumer, - tmp2); - top++; - ip -= sizeof(sexp); - goto make_call; - break; - case OP_RESUMECC: - tmp1 = stack[fp-1]; - top = sexp_restore_stack(sexp_vector_ref(cp, 0), stack); - fp = sexp_unbox_integer(_ARG1); - cp = _ARG2; - ip = (unsigned char*) sexp_unbox_integer(_ARG3); - i = sexp_unbox_integer(_ARG4); - top -= 4; - _ARG1 = tmp1; - break; - case OP_ERROR: - call_error_handler: - fprintf(stderr, "\n"); - sexp_print_exception(_ARG1, cur_error_port); - tmp1 = sexp_cdr(exception_handler_cell); - stack[top] = (sexp) 1; - stack[top+1] = sexp_make_integer(ip+4); - stack[top+2] = cp; - top+=3; - bc = sexp_procedure_code(tmp1); - ip = sexp_bytecode_data(bc); - cp = sexp_procedure_vars(tmp1); - break; - case OP_FCALL0: - _ARG1 = ((sexp_proc0)_ARG1)(); - if (sexp_exceptionp(_ARG1)) goto call_error_handler; - break; - case OP_FCALL1: - _ARG2 = ((sexp_proc1)_ARG1)(_ARG2); - top--; - if (sexp_exceptionp(_ARG1)) goto call_error_handler; - break; - case OP_FCALL2: - _ARG3 = ((sexp_proc2)_ARG1)(_ARG2, _ARG3); - top-=2; - if (sexp_exceptionp(_ARG1)) goto call_error_handler; - break; - case OP_FCALL3: - _ARG4 =((sexp_proc3)_ARG1)(_ARG2, _ARG3, _ARG4); - top-=3; - if (sexp_exceptionp(_ARG1)) goto call_error_handler; - break; - case OP_JUMP_UNLESS: - if (stack[--top] == SEXP_FALSE) { - ip += ((sexp_sint_t*)ip)[0]; - } else { - ip += sizeof(sexp_sint_t); - } - break; - case OP_JUMP: - ip += ((sexp_sint_t*)ip)[0]; - break; case OP_DISPLAY: if (sexp_stringp(_ARG1)) { sexp_write_string(sexp_string_data(_ARG1), _ARG2); @@ -1192,6 +1180,7 @@ sexp vm(sexp bc, sexp cp, sexp e, sexp* stack, sexp_sint_t top) { top--; break; } + /* ... FALLTHROUGH ... */ case OP_WRITE: sexp_write(_ARG1, _ARG2); _ARG2 = SEXP_UNDEF; @@ -1227,7 +1216,6 @@ sexp vm(sexp bc, sexp cp, sexp e, sexp* stack, sexp_sint_t top) { fp = sexp_unbox_integer(stack[fp+3]); break; case OP_DONE: - fprintf(stderr, "\n"); goto end_loop; default: sexp_raise("unknown opcode", sexp_list1(sexp_make_integer(*(ip-1)))); @@ -1305,8 +1293,8 @@ _OP(OPC_ARITHMETIC, OP_QUOT, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, 0, "quotient", _OP(OPC_ARITHMETIC, OP_MOD, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, 0, "modulo", NULL, NULL), _OP(OPC_ARITHMETIC_CMP, OP_LT, 0, 1, SEXP_FIXNUM, 0, 0, "<", NULL, NULL), _OP(OPC_ARITHMETIC_CMP, OP_LE, 0, 1, SEXP_FIXNUM, 0, 0, "<=", NULL, NULL), -_OP(OPC_ARITHMETIC_CMP, OP_GT, 0, 1, SEXP_FIXNUM, 0, OP_LE, ">", NULL, NULL), -_OP(OPC_ARITHMETIC_CMP, OP_GE, 0, 1, SEXP_FIXNUM, 0, OP_LT, ">=", NULL, NULL), +_OP(OPC_ARITHMETIC_CMP, OP_LT, 0, 1, SEXP_FIXNUM, 0, 1, ">", NULL, NULL), +_OP(OPC_ARITHMETIC_CMP, OP_LE, 0, 1, SEXP_FIXNUM, 0, 1, ">=", NULL, NULL), _OP(OPC_ARITHMETIC_CMP, OP_EQ, 0, 1, SEXP_FIXNUM, 0, 0, "=", NULL, NULL), _OP(OPC_PREDICATE, OP_EQ, 2, 0, 0, 0, 0, "eq?", NULL, NULL), _OP(OPC_CONSTRUCTOR, OP_CONS, 2, 0, 0, 0, 0, "cons", NULL, NULL), diff --git a/eval.h b/eval.h index e42cd467..b6714ff0 100644 --- a/eval.h +++ b/eval.h @@ -54,23 +54,22 @@ enum opcode_classes { enum opcode_names { OP_NOOP, + OP_ERROR, + OP_RESUMECC, + OP_CALLCC, + OP_APPLY1, OP_TAIL_CALL, OP_CALL, - OP_APPLY1, - OP_CALLCC, - OP_RESUMECC, - OP_EVAL, - OP_ERROR, OP_FCALL0, OP_FCALL1, OP_FCALL2, OP_FCALL3, - OP_FCALLN, + OP_EVAL, OP_JUMP_UNLESS, OP_JUMP, - OP_RET, - OP_DONE, OP_PARAMETER, + OP_PUSH, + OP_DROP, OP_STACK_REF, OP_LOCAL_REF, OP_LOCAL_SET, @@ -81,8 +80,6 @@ enum opcode_names { OP_STRING_SET, OP_MAKE_PROCEDURE, OP_MAKE_VECTOR, - OP_PUSH, - OP_DROP, OP_PAIRP, OP_NULLP, OP_VECTORP, @@ -109,9 +106,7 @@ enum opcode_names { OP_INV, OP_LT, OP_LE, - OP_GT, - OP_GE, - OP_EQN, + OP_EQV, OP_EQ, OP_DISPLAY, OP_WRITE, @@ -120,6 +115,8 @@ enum opcode_names { OP_FLUSH_OUTPUT, OP_READ, OP_READ_CHAR, + OP_RET, + OP_DONE, }; /**************************** prototypes ******************************/ diff --git a/init.scm b/init.scm index b8877e78..4615a9e0 100644 --- a/init.scm +++ b/init.scm @@ -76,6 +76,11 @@ ;; syntax +(define-syntax let + (lambda (expr use-env mac-env) + (cons (cons 'lambda (cons (map car (cadr expr)) (cddr expr))) + (map cadr (cadr expr))))) + (define-syntax letrec (lambda (expr use-env mac-env) (list @@ -84,11 +89,6 @@ (append (map (lambda (x) (cons 'define x)) (cadr expr)) (cddr expr))))))) -(define-syntax let - (lambda (expr use-env mac-env) - (cons (cons 'lambda (cons (map car (cadr expr)) (cddr expr))) - (map cadr (cadr expr))))) - (define-syntax or (lambda (expr use-env mac-env) (if (null? (cdr expr)) diff --git a/tests/test06-letrec.scm b/tests/test06-letrec.scm index fd3a9fa2..a9c01b4e 100644 --- a/tests/test06-letrec.scm +++ b/tests/test06-letrec.scm @@ -3,25 +3,13 @@ (write (add 3 4)) (newline)) -;; (letrec ((even? (lambda (n) (if (zero? n) #t (odd? (- n 1))))) -;; (odd? (lambda (n) (if (zero? n) #f (even? (- n 1)))))) -;; (write (even? 1000)) -;; (newline) -;; (write (even? 1001)) -;; (newline) -;; (write (odd? 1000)) -;; (newline) -;; ) - -((lambda (even? odd?) - (set! even? (lambda (n) (if (zero? n) #t (odd? (- n 1))))) - (set! odd? (lambda (n) (if (zero? n) #f (even? (- n 1))))) - (write (even? 100)) - (newline) - (write (even? 101)) - (newline) - (write (odd? 100)) - (newline) - ) - 'even 'odd) +(letrec ((even? (lambda (n) (if (zero? n) #t (odd? (- n 1))))) + (odd? (lambda (n) (if (zero? n) #f (even? (- n 1)))))) + (write (even? 1000)) + (newline) + (write (even? 1001)) + (newline) + (write (odd? 1000)) + (newline) + ) From 13565fb9de289c45f51766a798cf131f36b98f15 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 29 Mar 2009 22:10:09 +0900 Subject: [PATCH 068/154] initial hygiene working --- eval.c | 98 ++++++++++++++++++++++++---------------- init.scm | 29 ++++++++---- sexp.c | 35 +++++++++++++- tests/test09-hygiene.res | 4 ++ tests/test09-hygiene.scm | 12 +++++ 5 files changed, 129 insertions(+), 49 deletions(-) create mode 100644 tests/test09-hygiene.res create mode 100644 tests/test09-hygiene.scm diff --git a/eval.c b/eval.c index 2e9c99ff..8e87f8ef 100644 --- a/eval.c +++ b/eval.c @@ -125,7 +125,9 @@ static void shrink_bcode(sexp context, sexp_uint_t i) { if (sexp_bytecode_length(sexp_context_bc(context)) != i) { tmp = sexp_alloc_tagged(sexp_sizeof(bytecode) + i, SEXP_BYTECODE); sexp_bytecode_length(tmp) = i; - memcpy(sexp_bytecode_data(tmp), sexp_bytecode_data(sexp_context_bc(context)), i); + memcpy(sexp_bytecode_data(tmp), + sexp_bytecode_data(sexp_context_bc(context)), + i); sexp_context_bc(context) = tmp; } } @@ -181,6 +183,28 @@ static sexp sexp_make_macro (sexp p, sexp e) { return mac; } +static sexp sexp_make_synclo (sexp env, sexp fv, sexp expr) { + sexp res; + if (sexp_synclop(expr)) + return expr; + res = sexp_alloc_type(synclo, SEXP_SYNCLO); + sexp_synclo_env(res) = env; + sexp_synclo_free_vars(res) = fv; + sexp_synclo_expr(res) = expr; + return res; +} + +/* internal AST */ + +static sexp sexp_make_lambda(sexp params) { + sexp res = sexp_alloc_type(lambda, SEXP_LAMBDA); + sexp_lambda_params(res) = params; + sexp_lambda_fv(res) = SEXP_NULL; + sexp_lambda_sv(res) = SEXP_NULL; + sexp_lambda_locals(res) = SEXP_NULL; + return res; +} + static sexp sexp_make_set(sexp var, sexp value) { sexp res = sexp_alloc_type(set, SEXP_SET); sexp_set_var(res) = var; @@ -233,10 +257,10 @@ static sexp sexp_child_context(sexp context, sexp lambda) { return ctx; } -static int sexp_idp (sexp x) { - while (sexp_synclop(x)) - x = sexp_synclo_expr(x); - return sexp_symbolp(x); +#define sexp_idp(x) (sexp_symbolp(x) || (sexp_synclop(x) && sexp_symbolp(sexp_synclo_expr(x)))) + +static sexp sexp_identifierp (sexp x) { + return sexp_make_boolean(sexp_idp(x)); } /************************* the compiler ***************************/ @@ -258,9 +282,6 @@ static sexp sexp_compile_error(char *message, sexp irritants) { static sexp analyze (sexp x, sexp context) { sexp op, cell, res; loop: - fprintf(stderr, "analyze: "); - sexp_write(x, cur_error_port); - fprintf(stderr, "\n"); if (sexp_pairp(x)) { if (sexp_idp(sexp_car(x))) { cell = env_cell(sexp_context_env(context), sexp_car(x)); @@ -308,7 +329,7 @@ static sexp analyze (sexp x, sexp context) { } else { res = analyze_app(x, context); } - } else if (sexp_symbolp(x)) { + } else if (sexp_idp(x)) { res = analyze_var_ref(x, context); } else if (sexp_synclop(x)) { context = sexp_child_context(context, sexp_context_lambda(context)); @@ -324,11 +345,7 @@ static sexp analyze (sexp x, sexp context) { static sexp analyze_lambda (sexp x, sexp context) { sexp res, body; /* XXXX verify syntax */ - res = sexp_alloc_type(lambda, SEXP_LAMBDA); - sexp_lambda_params(res) = sexp_cadr(x); - sexp_lambda_fv(res) = SEXP_NULL; - sexp_lambda_sv(res) = SEXP_NULL; - sexp_lambda_locals(res) = SEXP_NULL; + res = sexp_make_lambda(sexp_cadr(x)); context = sexp_child_context(context, res); sexp_context_env(context) = extend_env(sexp_context_env(context), @@ -393,7 +410,17 @@ static sexp analyze_define (sexp x, sexp context) { } static sexp analyze_var_ref (sexp x, sexp context) { - sexp cell = env_cell_create(sexp_context_env(context), x, SEXP_UNDEF); + sexp cell = env_cell(sexp_context_env(context), x); + if (! cell) { + if (sexp_synclop(x)) { + cell = env_cell_create(sexp_synclo_env(x), + sexp_synclo_expr(x), + SEXP_UNDEF); + x = sexp_synclo_expr(x); + } else { + cell = env_cell_create(sexp_context_env(context), x, SEXP_UNDEF); + } + } return sexp_make_ref(x, cell); } @@ -579,9 +606,9 @@ static void generate_opcode_app (sexp app, sexp context) { } /* push the arguments onto the stack */ - ls = (sexp_opcode_inverse(op) - && ! sexp_opcode_class(op) == OPC_ARITHMETIC_INV) - ? sexp_cdr(app) : sexp_reverse(sexp_cdr(app)); + ls = ((sexp_opcode_inverse(op) + && (sexp_opcode_class(op) != OPC_ARITHMETIC_INV)) + ? sexp_cdr(app) : sexp_reverse(sexp_cdr(app))); for ( ; sexp_pairp(ls); ls = sexp_cdr(ls)) generate(sexp_car(ls), context); @@ -593,9 +620,7 @@ static void generate_opcode_app (sexp app, sexp context) { if (sexp_opcode_class(op) == OPC_FOREIGN) /* push the funtion pointer for foreign calls */ emit_push(sexp_opcode_data(op), context); - emit(sexp_opcode_inverse(op) ? sexp_opcode_inverse(op) - : sexp_opcode_code(op), - context); + emit(sexp_opcode_code(op), context); } /* emit optional folding of operator */ @@ -709,14 +734,12 @@ static sexp union_free_vars (sexp fv1, sexp fv2) { return fv2; } -static sexp diff_free_vars (sexp fv, sexp params) { +static sexp diff_free_vars (sexp lambda, sexp fv, sexp params) { sexp res = SEXP_NULL; -/* sexp_debug("diff-free-vars: ", fv); */ -/* sexp_debug("params: ", params); */ for ( ; sexp_pairp(fv); fv=sexp_cdr(fv)) - if (sexp_memq(sexp_ref_name(sexp_car(fv)), params) == SEXP_FALSE) + if ((sexp_ref_loc(sexp_car(fv)) != lambda) + || (sexp_memq(sexp_ref_name(sexp_car(fv)), params) == SEXP_FALSE)) sexp_push(res, sexp_car(fv)); -/* sexp_debug(" => ", res); */ return res; } @@ -724,7 +747,10 @@ static sexp free_vars (sexp x, sexp fv) { sexp fv1, fv2; if (sexp_lambdap(x)) { fv1 = free_vars(sexp_lambda_body(x), SEXP_NULL); - fv2 = diff_free_vars(fv1, sexp_flatten_dot(sexp_lambda_params(x))); + fv2 = diff_free_vars(x, + fv1, + sexp_append(sexp_lambda_locals(x), + sexp_flatten_dot(sexp_lambda_params(x)))); sexp_lambda_fv(x) = fv2; fv = union_free_vars(fv2, fv); } else if (sexp_pairp(x)) { @@ -742,6 +768,8 @@ static sexp free_vars (sexp x, sexp fv) { fv = free_vars(sexp_set_var(x), fv); } else if (sexp_refp(x) && sexp_lambdap(sexp_ref_loc(x))) { fv = insert_free_var(x, fv); + } else if (sexp_synclop(x)) { + fv = free_vars(sexp_synclo_expr(x), fv); } return fv; } @@ -763,11 +791,7 @@ static sexp make_opcode_procedure (sexp op, sexp_uint_t i, sexp env, return sexp_opcode_proc(op); params = make_param_list(i); context = sexp_new_context(stack); - lambda = sexp_alloc_type(lambda, SEXP_LAMBDA); - sexp_lambda_params(lambda) = params; - sexp_lambda_fv(lambda) = SEXP_NULL; - sexp_lambda_sv(lambda) = SEXP_NULL; - sexp_lambda_locals(lambda) = SEXP_NULL; + lambda = sexp_make_lambda(params); sexp_context_lambda(context) = lambda; sexp_context_top(context) = top; env = extend_env(env, params, lambda); @@ -828,7 +852,6 @@ sexp vm(sexp bc, sexp cp, sexp e, sexp* stack, sexp_sint_t top) { break; case OP_ERROR: call_error_handler: - fprintf(stderr, "\n"); sexp_print_exception(_ARG1, cur_error_port); tmp1 = sexp_cdr(exception_handler_cell); stack[top] = (sexp) 1; @@ -1276,6 +1299,7 @@ static struct sexp_struct opcodes[] = { #define _FN0(s, f) _FN(OP_FCALL0, 0, 0, 0, s, f) #define _FN1(t, s, f) _FN(OP_FCALL1, 1, t, 0, s, f) #define _FN2(t, u, s, f) _FN(OP_FCALL2, 2, t, u, s, f) +#define _FN3(t, u, s, f) _FN(OP_FCALL3, 3, t, u, s, f) #define _PARAM(n,a,t) _OP(OPC_PARAMETER, OP_PARAMETER, 0, 1, t, 0, 0, n, a, NULL) _OP(OPC_ACCESSOR, OP_CAR, 1, 0, SEXP_PAIR, 0, 0, "car", NULL, NULL), _OP(OPC_ACCESSOR, OP_SET_CAR, 2, 0, SEXP_PAIR, 0, 0, "set-car!", NULL, NULL), @@ -1320,6 +1344,7 @@ _OP(OPC_IO, OP_NEWLINE, 0, 3, 0, SEXP_OPORT, 0, "newline", (sexp)&cur_output_por _OP(OPC_IO, OP_FLUSH_OUTPUT, 0, 3, 0, SEXP_OPORT, 0, "flush-output", (sexp)&cur_output_port, NULL), _OP(OPC_IO, OP_READ, 0, 3, 0, SEXP_IPORT, 0, "read", (sexp)&cur_input_port, NULL), _OP(OPC_IO, OP_READ_CHAR, 0, 3, 0, SEXP_IPORT, 0, "read-char", (sexp)&cur_input_port, NULL), +_FN1(0, "identifier?", sexp_identifierp), _FN1(SEXP_PAIR, "length", sexp_length), _FN1(SEXP_PAIR, "reverse", sexp_reverse), _FN1(SEXP_PAIR, "list->vector", sexp_list_to_vector), @@ -1330,16 +1355,11 @@ _FN1(SEXP_OPORT, "close-output-port", sexp_close_port), _FN1(0, "load", sexp_load), _FN2(0, SEXP_PAIR, "memq", sexp_memq), _FN2(0, SEXP_PAIR, "assq", sexp_assq), +_FN3(SEXP_ENV, SEXP_PAIR, "make-syntactic-closure", sexp_make_synclo), _PARAM("current-input-port", (sexp)&cur_input_port, SEXP_IPORT), _PARAM("current-output-port", (sexp)&cur_output_port, SEXP_OPORT), _PARAM("current-error-port", (sexp)&cur_error_port, SEXP_OPORT), _PARAM("interaction-environment", (sexp)&interaction_environment, SEXP_ENV), -#undef _OP -#undef _FN -#undef _FN0 -#undef _FN1 -#undef _FN2 -#undef _PARAM }; sexp make_standard_env () { diff --git a/init.scm b/init.scm index 4615a9e0..d57d5dbb 100644 --- a/init.scm +++ b/init.scm @@ -76,6 +76,16 @@ ;; syntax +(define sc-macro-transformer + (lambda (f) + (lambda (expr use-env mac-env) + (make-syntactic-closure mac-env '() (f expr use-env))))) + +(define rsc-macro-transformer + (lambda (f) + (lambda (expr use-env mac-env) + (make-syntactic-closure use-env '() (f expr mac-env))))) + (define-syntax let (lambda (expr use-env mac-env) (cons (cons 'lambda (cons (map car (cadr expr)) (cddr expr))) @@ -90,12 +100,13 @@ (cddr expr))))))) (define-syntax or - (lambda (expr use-env mac-env) - (if (null? (cdr expr)) - #f - (if (null? (cddr expr)) - (cadr expr) - (list 'let (list (list 'tmp (cadr expr))) - (list 'if 'tmp - 'tmp - (cons 'or (cddr expr)))))))) + (sc-macro-transformer + (lambda (expr use-env) + (if (null? (cdr expr)) + #f + (if (null? (cddr expr)) + (make-syntactic-closure use-env '() (cadr expr)) + (list 'let (list (list 'tmp (make-syntactic-closure use-env '() (cadr expr)))) + (list 'if 'tmp + 'tmp + (make-syntactic-closure use-env '() (cons 'or (cddr expr)))))))))) diff --git a/sexp.c b/sexp.c index bd9ef1c1..fc82f1bb 100644 --- a/sexp.c +++ b/sexp.c @@ -458,13 +458,46 @@ void sexp_write (sexp obj, sexp out) { sexp_write_string("#", out); break; case SEXP_MACRO: sexp_write_string("#", out); break; +#if USE_DEBUG case SEXP_LAMBDA: - sexp_write_string("#", out); break; + sexp_write_string("#', out); + break; + case SEXP_SEQ: + sexp_write_string("#', out); + break; + case SEXP_CND: + sexp_write_string("#', out); + break; case SEXP_REF: sexp_write_string("#", sexp_ref_loc(obj)); + break; + case SEXP_SET: + sexp_write_string("#", out); break; + case SEXP_SYNCLO: + sexp_write_string("#", out); + break; +#endif case SEXP_STRING: sexp_write_char('"', out); i = sexp_string_length(obj); diff --git a/tests/test09-hygiene.res b/tests/test09-hygiene.res new file mode 100644 index 00000000..94ebaf90 --- /dev/null +++ b/tests/test09-hygiene.res @@ -0,0 +1,4 @@ +1 +2 +3 +4 diff --git a/tests/test09-hygiene.scm b/tests/test09-hygiene.scm new file mode 100644 index 00000000..f6c547a4 --- /dev/null +++ b/tests/test09-hygiene.scm @@ -0,0 +1,12 @@ + +(write (or 1)) +(newline) +(write (or #f 2)) +(newline) +(write (or 3 #t)) +(newline) + +(let ((tmp 4)) + (write (or #f tmp)) + (newline)) + From 95240dbe74b30cf97cc761bc735b119be7ceacb6 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 30 Mar 2009 03:09:33 +0900 Subject: [PATCH 069/154] adding some math operations. parameters now directly reference global env. --- config.h | 3 ++ debug.c | 3 +- defaults.h | 4 ++ eval.c | 119 ++++++++++++++++++++++++++++++++++++++--------------- eval.h | 5 ++- init.scm | 45 ++++++++++++++++++++ 6 files changed, 143 insertions(+), 36 deletions(-) diff --git a/config.h b/config.h index 132d4211..da09e126 100644 --- a/config.h +++ b/config.h @@ -8,6 +8,9 @@ /* uncomment this if you only want fixnum support */ /* #define USE_FLONUMS 0 */ +/* uncomment this if you don't need extended math operations */ +/* #define USE_MATH 0 */ + /* uncomment this to disable huffman-coded immediate symbols */ /* #define USE_HUFF_SYMS 0 */ diff --git a/debug.c b/debug.c index 2ce3ee6e..bd1593a8 100644 --- a/debug.c +++ b/debug.c @@ -5,7 +5,7 @@ static const char* reverse_opcode_names[] = {"NOOP", "ERROR", "RESUMECC", "CALLCC", "APPLY1", "TAIL_CALL", "CALL", "FCALL0", "FCALL1", "FCALL2", "FCALL3", "EVAL", "JUMP_UNLESS", "JUMP", - "PARAMETER", "PUSH", "DROP", "STACK_REF", "LOCAL_REF", "LOCAL_SET", + "PUSH", "DROP", "STACK_REF", "LOCAL_REF", "LOCAL_SET", "CLOSURE_REF", "VECTOR_REF", "VECTOR_SET", "STRING_REF", "STRING_SET", "MAKE_PROCEDURE", "MAKE_VECTOR", "PAIRP", "NULLP", "VECTORP", "INTEGERP", "SYMBOLP", "STRINGP", "CHARP", "EOFP", "PROCEDUREP", "IPORTP", "OPORTP", @@ -28,7 +28,6 @@ void disasm (sexp bc) { case OP_LOCAL_REF: case OP_LOCAL_SET: case OP_CLOSURE_REF: - case OP_PARAMETER: case OP_JUMP: case OP_JUMP_UNLESS: fprintf(stderr, "%ld", (sexp_sint_t) ((sexp*)ip)[0]); diff --git a/defaults.h b/defaults.h index 5215de72..25c99b47 100644 --- a/defaults.h +++ b/defaults.h @@ -23,6 +23,10 @@ #define USE_FLONUMS 1 #endif +#ifndef USE_MATH +#define USE_MATH 1 +#endif + #ifndef USE_HUFF_SYMS #define USE_HUFF_SYMS 1 #endif diff --git a/eval.c b/eval.c index 8e87f8ef..b140279f 100644 --- a/eval.c +++ b/eval.c @@ -78,7 +78,7 @@ static sexp env_cell_create(sexp e, sexp key, sexp value) { static void env_define(sexp e, sexp key, sexp value) { sexp cell = sexp_assq(key, sexp_env_bindings(e)); if (cell != SEXP_FALSE) - sexp_cdr(cell) = value; + sexp_cdar(cell) = value; else sexp_push(sexp_env_bindings(e), sexp_cons(key, value)); } @@ -594,13 +594,11 @@ static void generate_opcode_app (sexp app, sexp context) { /* maybe push the default for an optional argument */ if ((num_args == sexp_opcode_num_args(op)) - && sexp_opcode_variadic_p(op) && sexp_opcode_data(op)) { - emit(OP_PARAMETER, context); - emit_word((sexp_uint_t)sexp_opcode_data(op), context); - if (! sexp_opcode_opt_param_p(op)) { - emit(OP_CALL, context); - emit_word((sexp_uint_t)sexp_make_integer(0), context); - } + && sexp_opcode_variadic_p(op) + && sexp_opcode_data(op) + && sexp_opcode_opt_param_p(op)) { + emit_push(sexp_opcode_data(op), context); + emit(OP_CDR, context); sexp_context_depth(context)++; num_args++; } @@ -617,10 +615,16 @@ static void generate_opcode_app (sexp app, sexp context) { emit((num_args == 1) ? sexp_opcode_inverse(op) : sexp_opcode_code(op), context); } else { - if (sexp_opcode_class(op) == OPC_FOREIGN) + if (sexp_opcode_class(op) == OPC_FOREIGN) { /* push the funtion pointer for foreign calls */ emit_push(sexp_opcode_data(op), context); - emit(sexp_opcode_code(op), context); + emit(sexp_opcode_code(op), context); + } else if (sexp_opcode_class(op) == OPC_PARAMETER) { + emit_push(sexp_opcode_data(op), context); + emit(OP_CDR, context); + } else { + emit(sexp_opcode_code(op), context); + } } /* emit optional folding of operator */ @@ -634,9 +638,6 @@ static void generate_opcode_app (sexp app, sexp context) { } } - if (sexp_opcode_class(op) == OPC_PARAMETER) - emit_word((sexp_uint_t)sexp_opcode_data(op), context); - sexp_context_depth(context) -= (num_args-1); } @@ -988,10 +989,6 @@ sexp vm(sexp bc, sexp cp, sexp e, sexp* stack, sexp_sint_t top) { case OP_JUMP: ip += ((sexp_sint_t*)ip)[0]; break; - case OP_PARAMETER: - _PUSH(*(sexp*)((sexp*)ip)[0]); - ip += sizeof(sexp); - break; case OP_PUSH: _PUSH(((sexp*)ip)[0]); ip += sizeof(sexp); @@ -1279,6 +1276,37 @@ sexp sexp_load (sexp source) { return res; } +#if USE_MATH + +static sexp sexp_math_exception (char *message, sexp obj) { + return sexp_make_exception(sexp_intern("type-error"), + sexp_make_string(message), + sexp_list1(obj), SEXP_FALSE, SEXP_FALSE); +} + +#define define_math_op(name, cname) \ + static sexp name (sexp z) { \ + double d; \ + if (sexp_flonump(z)) \ + d = sexp_flonum_value(z); \ + else if (sexp_integerp(z)) \ + d = (double)sexp_unbox_integer(z); \ + else \ + return sexp_math_exception("not a number", z); \ + return sexp_make_flonum(cname(d)); \ + } + +define_math_op(sexp_exp, exp) +define_math_op(sexp_log, log) +define_math_op(sexp_sin, sin) +define_math_op(sexp_cos, cos) +define_math_op(sexp_tan, tan) +define_math_op(sexp_asin, asin) +define_math_op(sexp_acos, acos) +define_math_op(sexp_atan, atan) + +#endif + /*********************** standard environment *************************/ static struct sexp_struct core_forms[] = { @@ -1300,7 +1328,7 @@ static struct sexp_struct opcodes[] = { #define _FN1(t, s, f) _FN(OP_FCALL1, 1, t, 0, s, f) #define _FN2(t, u, s, f) _FN(OP_FCALL2, 2, t, u, s, f) #define _FN3(t, u, s, f) _FN(OP_FCALL3, 3, t, u, s, f) -#define _PARAM(n,a,t) _OP(OPC_PARAMETER, OP_PARAMETER, 0, 1, t, 0, 0, n, a, NULL) +#define _PARAM(n,a,t) _OP(OPC_PARAMETER, OP_NOOP, 0, 2, t, 0, 0, n, a, NULL) _OP(OPC_ACCESSOR, OP_CAR, 1, 0, SEXP_PAIR, 0, 0, "car", NULL, NULL), _OP(OPC_ACCESSOR, OP_SET_CAR, 2, 0, SEXP_PAIR, 0, 0, "set-car!", NULL, NULL), _OP(OPC_ACCESSOR, OP_CDR, 1, 0, SEXP_PAIR, 0, 0, "cdr", NULL, NULL), @@ -1337,13 +1365,13 @@ _OP(OPC_TYPE_PREDICATE, OP_EOFP, 1, 0, 0, 0, 0, "eof-object?", NULL, NULL), _OP(OPC_GENERIC, OP_APPLY1, 2, 0, SEXP_PROCEDURE, SEXP_PAIR, 0, "apply1", NULL, NULL), _OP(OPC_GENERIC, OP_CALLCC, 1, SEXP_PROCEDURE, 0, 0, 0, "call-with-current-continuation", NULL, NULL), _OP(OPC_GENERIC, OP_ERROR, 1, SEXP_STRING, 0, 0, 0, "error", NULL, NULL), -_OP(OPC_IO, OP_WRITE, 1, 3, 0, SEXP_OPORT, 0, "write", (sexp)&cur_output_port, NULL), -_OP(OPC_IO, OP_DISPLAY, 1, 3, 0, SEXP_OPORT, 0, "display", (sexp)&cur_output_port, NULL), -_OP(OPC_IO, OP_WRITE_CHAR, 1, 3, 0, SEXP_OPORT, 0, "write-char", (sexp)&cur_output_port, NULL), -_OP(OPC_IO, OP_NEWLINE, 0, 3, 0, SEXP_OPORT, 0, "newline", (sexp)&cur_output_port, NULL), -_OP(OPC_IO, OP_FLUSH_OUTPUT, 0, 3, 0, SEXP_OPORT, 0, "flush-output", (sexp)&cur_output_port, NULL), -_OP(OPC_IO, OP_READ, 0, 3, 0, SEXP_IPORT, 0, "read", (sexp)&cur_input_port, NULL), -_OP(OPC_IO, OP_READ_CHAR, 0, 3, 0, SEXP_IPORT, 0, "read-char", (sexp)&cur_input_port, NULL), +_OP(OPC_IO, OP_WRITE, 1, 3, 0, SEXP_OPORT, 0, "write", (sexp)"*current-output-port*", NULL), +_OP(OPC_IO, OP_DISPLAY, 1, 3, 0, SEXP_OPORT, 0, "display", (sexp)"*current-output-port*", NULL), +_OP(OPC_IO, OP_WRITE_CHAR, 1, 3, 0, SEXP_OPORT, 0, "write-char", (sexp)"*current-output-port*", NULL), +_OP(OPC_IO, OP_NEWLINE, 0, 3, 0, SEXP_OPORT, 0, "newline", (sexp)"*current-output-port*", NULL), +_OP(OPC_IO, OP_FLUSH_OUTPUT, 0, 3, 0, SEXP_OPORT, 0, "flush-output", (sexp)"*current-output-port*", NULL), +_OP(OPC_IO, OP_READ, 0, 3, 0, SEXP_IPORT, 0, "read", (sexp)"*current-input-port*", NULL), +_OP(OPC_IO, OP_READ_CHAR, 0, 3, 0, SEXP_IPORT, 0, "read-char", (sexp)"*current-input-port*", NULL), _FN1(0, "identifier?", sexp_identifierp), _FN1(SEXP_PAIR, "length", sexp_length), _FN1(SEXP_PAIR, "reverse", sexp_reverse), @@ -1353,13 +1381,24 @@ _FN1(SEXP_STRING, "open-output-file", sexp_open_output_file), _FN1(SEXP_IPORT, "close-input-port", sexp_close_port), _FN1(SEXP_OPORT, "close-output-port", sexp_close_port), _FN1(0, "load", sexp_load), +#if USE_MATH +_FN1(0, "exp", sexp_exp), +_FN1(0, "log", sexp_log), +_FN1(0, "sin", sexp_sin), +_FN1(0, "cos", sexp_cos), +_FN1(0, "tan", sexp_tan), +_FN1(0, "asin", sexp_asin), +_FN1(0, "acos", sexp_acos), +_FN1(0, "atan", sexp_atan), +#endif _FN2(0, SEXP_PAIR, "memq", sexp_memq), _FN2(0, SEXP_PAIR, "assq", sexp_assq), _FN3(SEXP_ENV, SEXP_PAIR, "make-syntactic-closure", sexp_make_synclo), -_PARAM("current-input-port", (sexp)&cur_input_port, SEXP_IPORT), -_PARAM("current-output-port", (sexp)&cur_output_port, SEXP_OPORT), -_PARAM("current-error-port", (sexp)&cur_error_port, SEXP_OPORT), -_PARAM("interaction-environment", (sexp)&interaction_environment, SEXP_ENV), +_PARAM("current-input-port", (sexp)"*current-input-port*", SEXP_IPORT), +_PARAM("current-output-port", (sexp)"*current-output-port*", SEXP_OPORT), +_PARAM("current-error-port", (sexp)"*current-error-port*", SEXP_OPORT), +_PARAM("current-error-handler", (sexp)"*current-error-handler*", SEXP_PROCEDURE), +_PARAM("interaction-environment", (sexp)"*interaction-environment*", SEXP_ENV), }; sexp make_standard_env () { @@ -1369,8 +1408,15 @@ sexp make_standard_env () { sexp_env_bindings(e) = SEXP_NULL; for (i=0; i<(sizeof(core_forms)/sizeof(core_forms[0])); i++) env_define(e, sexp_intern(sexp_core_name(&core_forms[i])), &core_forms[i]); - for (i=0; i<(sizeof(opcodes)/sizeof(opcodes[0])); i++) + for (i=0; i<(sizeof(opcodes)/sizeof(opcodes[0])); i++) { + if (sexp_opcode_opt_param_p(&opcodes[i]) + && sexp_opcode_data(&opcodes[i])) + sexp_opcode_data(&opcodes[i]) + = env_cell_create(e, + sexp_intern((char*)sexp_opcode_data(&opcodes[i])), + SEXP_UNDEF); env_define(e, sexp_intern(sexp_opcode_name(&opcodes[i])), &opcodes[i]); + } return e; } @@ -1460,11 +1506,10 @@ void repl (sexp context) { } } -int main (int argc, char **argv) { +void run_main (int argc, char **argv) { sexp env, obj, res, context, err_handler, err_handler_sym; sexp_uint_t i, quit=0, init_loaded=0; - scheme_init(); env = make_standard_env(); interaction_environment = env; context = sexp_new_context(NULL); @@ -1476,8 +1521,11 @@ int main (int argc, char **argv) { sexp_make_integer(0), finalize_bytecode(context), sexp_make_vector(0, SEXP_UNDEF)); - err_handler_sym = sexp_intern("*error-handler*"); + err_handler_sym = sexp_intern("*current-error-handler*"); env_define(env, err_handler_sym, err_handler); + env_define(env, sexp_intern("*current-input-port*"), cur_input_port); + env_define(env, sexp_intern("*current-output-port*"), cur_output_port); + env_define(env, sexp_intern("*current-error-port*"), cur_error_port); exception_handler_cell = env_cell(env, err_handler_sym); /* parse options */ @@ -1515,6 +1563,11 @@ int main (int argc, char **argv) { else repl(context); } +} + +int main (int argc, char **argv) { + scheme_init(); + run_main(argc, argv); return 0; } diff --git a/eval.h b/eval.h index b6714ff0..3648d36d 100644 --- a/eval.h +++ b/eval.h @@ -7,6 +7,10 @@ #include "sexp.h" +#if USE_MATH +#include +#endif + /************************* additional types ***************************/ #define INIT_BCODE_SIZE 128 @@ -67,7 +71,6 @@ enum opcode_names { OP_EVAL, OP_JUMP_UNLESS, OP_JUMP, - OP_PARAMETER, OP_PUSH, OP_DROP, OP_STACK_REF, diff --git a/init.scm b/init.scm index d57d5dbb..31811903 100644 --- a/init.scm +++ b/init.scm @@ -1,4 +1,36 @@ +;; define set! let let* letrec lambda if cond case delay and or begin do +;; quote quasiquote unquote unquote-splicing define-syntax let-syntax +;; letrec-syntax syntax-rules eqv? eq? equal? not boolean? number? +;; complex? real? rational? integer? exact? inexact? = < > <= >= zero? +;; positive? negative? odd? even? max min + * - / abs quotient remainder +;; modulo gcd lcm numerator denominator floor ceiling truncate round +;; rationalize exp log sin cos tan asin acos atan sqrt expt +;; make-rectangular make-polar real-part imag-part magnitude angle +;; exact->inexact inexact->exact number->string string->number pair? cons +;; car cdr set-car! set-cdr! caar cadr cdar cddr caaar caadr cadar caddr +;; cdaar cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr +;; caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr +;; null? list? list length append reverse list-tail list-ref memq memv +;; member assq assv assoc symbol? symbol->string string->symbol char? +;; char=? char? char<=? char>=? char-ci=? char-ci? +;; char-ci<=? char-ci>=? char-alphabetic? char-numeric? char-whitespace? +;; char-upper-case? char-lower-case? char->integer integer->char +;; char-upcase char-downcase string? make-string string string-length +;; string-ref string-set! string=? string-ci=? string? +;; string<=? string>=? string-ci? string-ci<=? string-ci>=? +;; substring string-append string->list list->string string-copy +;; string-fill! vector? make-vector vector vector-length vector-ref +;; vector-set! vector->list list->vector vector-fill! procedure? apply +;; map for-each force call-with-current-continuation values +;; call-with-values dynamic-wind scheme-report-environment +;; null-environment call-with-input-file call-with-output-file +;; input-port? output-port? current-input-port current-output-port +;; with-input-from-file with-output-to-file open-input-file +;; open-output-file close-input-port close-output-port read read-char +;; peek-char eof-object? char-ready? write display newline write-char +;; load eval + ;; provide c[ad]{2,4}r (define (caar x) (car (car x))) @@ -110,3 +142,16 @@ (list 'if 'tmp 'tmp (make-syntactic-closure use-env '() (cons 'or (cddr expr)))))))))) + +;; math + +;; (define (abs x) (if (< x 0) (- x) x)) + +;; (define (gcd a b) +;; (if (= b 0) +;; a +;; (gcd b (modulo a b)))) + +;; (define (lcm a b) +;; (quotient (* a b) (gcd a b))) + From 1f6493cb3d1731d6fb94fea12c36a18b2162fd63 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 31 Mar 2009 13:57:50 +0900 Subject: [PATCH 070/154] more primitives --- init.scm | 61 ++++++++++------ syntax-rules.scm | 177 +++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 215 insertions(+), 23 deletions(-) create mode 100644 syntax-rules.scm diff --git a/init.scm b/init.scm index 31811903..95ea7c97 100644 --- a/init.scm +++ b/init.scm @@ -1,35 +1,31 @@ -;; define set! let let* letrec lambda if cond case delay and or begin do -;; quote quasiquote unquote unquote-splicing define-syntax let-syntax -;; letrec-syntax syntax-rules eqv? eq? equal? not boolean? number? -;; complex? real? rational? integer? exact? inexact? = < > <= >= zero? -;; positive? negative? odd? even? max min + * - / abs quotient remainder -;; modulo gcd lcm numerator denominator floor ceiling truncate round -;; rationalize exp log sin cos tan asin acos atan sqrt expt +;; let* cond case delay and do +;; quasiquote unquote unquote-splicing let-syntax +;; letrec-syntax syntax-rules eqv? equal? not boolean? number? +;; complex? real? rational? integer? exact? inexact? +;; positive? negative? odd? even? max min quotient remainder +;; modulo numerator denominator floor ceiling truncate round +;; rationalize sqrt expt ;; make-rectangular make-polar real-part imag-part magnitude angle -;; exact->inexact inexact->exact number->string string->number pair? cons -;; car cdr set-car! set-cdr! caar cadr cdar cddr caaar caadr cadar caddr -;; cdaar cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr -;; caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr -;; null? list? list length append reverse list-tail list-ref memq memv -;; member assq assv assoc symbol? symbol->string string->symbol char? -;; char=? char? char<=? char>=? char-ci=? char-ci? -;; char-ci<=? char-ci>=? char-alphabetic? char-numeric? char-whitespace? +;; exact->inexact inexact->exact number->string string->number +;; list? list-tail list-ref memv +;; member assv assoc symbol->string string->symbol +;; char-alphabetic? char-numeric? char-whitespace? ;; char-upper-case? char-lower-case? char->integer integer->char -;; char-upcase char-downcase string? make-string string string-length -;; string-ref string-set! string=? string-ci=? string? +;; char-upcase char-downcase make-string string string-length +;; string=? string-ci=? string? ;; string<=? string>=? string-ci? string-ci<=? string-ci>=? ;; substring string-append string->list list->string string-copy -;; string-fill! vector? make-vector vector vector-length vector-ref -;; vector-set! vector->list list->vector vector-fill! procedure? apply +;; string-fill! make-vector vector vector-length +;; vector->list list->vector vector-fill! procedure? apply ;; map for-each force call-with-current-continuation values ;; call-with-values dynamic-wind scheme-report-environment ;; null-environment call-with-input-file call-with-output-file -;; input-port? output-port? current-input-port current-output-port +;; current-input-port current-output-port ;; with-input-from-file with-output-to-file open-input-file -;; open-output-file close-input-port close-output-port read read-char -;; peek-char eof-object? char-ready? write display newline write-char -;; load eval +;; open-output-file close-input-port close-output-port +;; peek-char eof-object? char-ready? +;; eval ;; provide c[ad]{2,4}r @@ -143,6 +139,25 @@ 'tmp (make-syntactic-closure use-env '() (cons 'or (cddr expr)))))))))) +;; char utils + +;; (define (char=? a b) (= (char->integer a) (char->integer b))) +;; (define (charinteger a) (char->integer b))) +;; (define (char>? a b) (> (char->integer a) (char->integer b))) +;; (define (char<=? a b) (<= (char->integer a) (char->integer b))) +;; (define (char>=? a b) (>= (char->integer a) (char->integer b))) + +;; (define (char-ci=? a b) +;; (= (char->integer (char-downcase a)) (char->integer (char-downcase b)))) +;; (define (char-ciinteger (char-downcase a)) (char->integer (char-downcase b)))) +;; (define (char-ci>? a b) +;; (> (char->integer (char-downcase a)) (char->integer (char-downcase b)))) +;; (define (char-ci<=? a b) +;; (<= (char->integer (char-downcase a)) (char->integer (char-downcase b)))) +;; (define (char-ci>=? a b) +;; (>= (char->integer (char-downcase a)) (char->integer (char-downcase b)))) + ;; math ;; (define (abs x) (if (< x 0) (- x) x)) diff --git a/syntax-rules.scm b/syntax-rules.scm new file mode 100644 index 00000000..687b5384 --- /dev/null +++ b/syntax-rules.scm @@ -0,0 +1,177 @@ + +(define-syntax syntax-rules + (er-macro-transformer + (lambda (expr rename compare) + (let ((lits (cadr expr)) + (forms (cddr expr)) + (count 0) + (_er-macro-transformer (rename 'er-macro-transformer)) + (_lambda (rename 'lambda)) (_let (rename 'let)) + (_begin (rename 'begin)) (_if (rename 'if)) + (_and (rename 'and)) (_or (rename 'or)) + (_eq? (rename 'eq?)) (_equal? (rename 'equal?)) + (_car (rename 'car)) (_cdr (rename 'cdr)) + (_cons (rename 'cons)) (_pair? (rename 'pair?)) + (_null? (rename 'null?)) (_expr (rename 'expr)) + (_rename (rename 'rename)) (_compare (rename 'compare)) + (_quote (rename 'quote)) (_apply (rename 'apply)) + (_append (rename 'append)) (_map (rename 'map)) + (_vector? (rename 'vector?)) (_list? (rename 'list?)) + (_lp (rename 'lp)) (_reverse (rename 'reverse)) + (_vector->list (rename 'vector->list)) + (_list->vector (rename 'list->vector))) + (define (next-v) + (set! count (+ count 1)) + (rename (string->symbol (string-append "v." (number->string count))))) + (define (expand-pattern pat tmpl) + (let lp ((p (cdr pat)) + (x (list _cdr _expr)) + (dim 0) + (vars '()) + (k (lambda (vars) + (or (expand-template tmpl vars) + (list _begin #f))))) + (let ((v (next-v))) + (list + _let (list (list v x)) + (cond + ((symbol? p) + (if (memq p lits) + (list _and (list _eq? v p) (k vars)) + (list _let (list (list p v)) (k (cons (cons p dim) vars))))) + ((ellipse? p) + (cond + ((not (null? (cddr p))) + (error "non-trailing ellipse" p)) + ((symbol? (car p)) + (list _and (list _list? v) + (list _let (list (list (car p) v)) + (k (cons (cons (car p) (+ 1 dim)) vars))))) + (else + (let* ((w (next-v)) + (new-vars (all-vars (car p) (+ dim 1))) + (ls-vars (map (lambda (x) + (rename (string->symbol + (string-append + (symbol->string (car x)) + "-ls")))) + new-vars)) + (once + (lp (car p) (list _car w) (+ dim 1) '() + (lambda (_) + (cons + _lp + (cons + (list _cdr w) + (map (lambda (x l) + (list _cons (car x) l)) + new-vars + ls-vars))))))) + (list + _let + _lp (list (list w v) + (map (lambda (x) (list x '())) ls-vars)) + (list _if (list _null? w) + (list _let (map (lambda (x l) + (list (car x) (list _reverse l))) + new-vars + ls-vars) + (k (append new-vars vars))) + (list _and (list _pair? w) once))))))) + ((pair? p) + (list _and (list _pair? v) + (lp (car p) + (list _car v) + dim + vars + (lambda (vars) + (lp (cdr p) (list _cdr v) dim vars k))))) + ((vector? p) + (list _and + (list _vector? v) + (lp (vector->list p) (list _vector->list v) dim vars k))) + ((null? p) (list _and (list _null? v) (k vars))) + (else (list _and (list _equal? v p) (k vars)))))))) + (define (ellipse? x) + (and (pair? x) (pair? (cdr x)) (eq? '... (cadr x)))) + (define (ellipse-depth x) + (if (ellipse? x) + (+ 1 (ellipse-depth (cdr x))) + 0)) + (define (ellipse-tail x) + (if (ellipse? x) + (ellipse-tail (cdr x)) + (cdr x))) + (define (all-vars x dim) + (let lp ((x x) (dim dim) (vars '())) + (cond ((symbol? x) (if (memq x lits) vars (cons (cons x dim) vars))) + ((ellipse? x) (lp (car x) (+ dim 1) vars)) + ((pair? x) (lp (car x) dim (lp (cdr x) dim vars))) + ((vector? x) (lp (vector->list x) dim vars)) + (else vars)))) + (define (free-vars x vars dim) + (let lp ((x x) (free '())) + (cond ((symbol? x) + (if (and (not (memq x free)) + (cond ((assq x vars) + => (lambda (cell) (>= (cdr cell) dim))) + (else #f))) + (cons x free) + free)) + ((pair? x) (free-vars (car x) (free-vars (cdr x) free))) + ((vector? x) (lp (vector->list x) free)) + (else free)))) + (define (expand-template tmpl vars) + (let lp ((t tmpl) (dim 0)) + (cond + ((symbol? t) + (cond + ((assq t vars) + => (lambda (cell) + (if (<= (cdr cell) dim) + t + (error "too few ...'s for" t tmpl)))) + (else + (list _rename (list _quote t))))) + ((pair? t) + (if (ellipse? t) + (let* ((depth (ellipse-depth t)) + (ell-dim (+ dim depth)) + (ell-vars (free-vars (car t) vars ell-dim))) + (if (null? ell-vars) + (error "too many ...'s" tmpl t) + (let* ((once (lp (car t) ell-dim)) + (nest (if (and (null? (cdr ell-vars)) + (symbol? once) + (eq? once (car vars))) + once ;; shortcut + (cons _map + (cons (list _lambda ell-vars once) + ell-vars)))) + (many (do ((d depth (- d 1)) + (many nest + (list _apply _append many))) + ((= d 1) many)))) + (if (null? (ellipse-tail t)) + many ;; shortcut + (list _append many (lp (ellipse-tail t) dim)))))) + (list _cons (lp (car t) dim) (lp (cdr t) dim)))) + ((vector? t) (list _list->vector (lp (vector->list t) dim))) + ((null? t) (list _quote '())) + (else t)))) + (list + _er-macro-transformer + (list _lambda (list _expr _rename _compare) + (cons + _or + (map + (lambda (clause) (expand-pattern (car clause) (cadr clause))) + forms) + (error "no expansion for" _expr)))))))) + +;; Local Variables: +;; eval: (put '_lambda 'scheme-indent-function 1) +;; eval: (put '_let 'scheme-indent-function 'scheme-let-indent) +;; eval: (put '_if 'scheme-indent-function 3) +;; End: + From eaf79f4856e5d5f6cfaded8a1a3e074959ed4933 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 31 Mar 2009 17:42:09 +0900 Subject: [PATCH 071/154] internal defines should do the right thing now --- eval.c | 90 +++++++++++++++++++++++++++++++++++++++++++++------------- sexp.c | 2 ++ sexp.h | 3 +- 3 files changed, 75 insertions(+), 20 deletions(-) diff --git a/eval.c b/eval.c index b140279f..1a452840 100644 --- a/eval.c +++ b/eval.c @@ -114,7 +114,7 @@ static int sexp_param_index (sexp lambda, sexp name) { ls = sexp_lambda_locals(lambda); for (i=-1; sexp_pairp(ls); ls=sexp_cdr(ls), i--) if (sexp_car(ls) == name) - return i; + return i-4; return -10000; } @@ -202,6 +202,7 @@ static sexp sexp_make_lambda(sexp params) { sexp_lambda_fv(res) = SEXP_NULL; sexp_lambda_sv(res) = SEXP_NULL; sexp_lambda_locals(res) = SEXP_NULL; + sexp_lambda_defs(res) = SEXP_NULL; return res; } @@ -271,19 +272,21 @@ static sexp sexp_compile_error(char *message, sexp irritants) { irritants, SEXP_FALSE, SEXP_FALSE); } -#define analyze_check_exception(x) do {if (sexp_exceptionp(x)) \ - return (x); \ +#define analyze_check_exception(x) do {if (sexp_exceptionp(x)) \ + return (x); \ } while (0) -#define analyze_bind(var, x, context) do {(var) = analyze(x,context); \ - analyze_check_exception(var); \ +#define analyze_bind(var, x, context) do {(var) = analyze(x,context); \ + analyze_check_exception(var); \ } while (0) static sexp analyze (sexp x, sexp context) { sexp op, cell, res; loop: if (sexp_pairp(x)) { - if (sexp_idp(sexp_car(x))) { + if (! sexp_listp(x)) { + res = sexp_compile_error("dotted list in source", sexp_list1(x)); + } else if (sexp_idp(sexp_car(x))) { cell = env_cell(sexp_context_env(context), sexp_car(x)); if (! cell) return analyze_app(x, context); op = sexp_cdr(cell); @@ -318,6 +321,7 @@ static sexp analyze (sexp x, sexp context) { x = apply(sexp_macro_proc(op), sexp_list3(x, sexp_context_env(context), sexp_macro_env(op)), context); + sexp_debug("expanded => ", x); goto loop; } else if (sexp_opcodep(op)) { res = analyze_app(sexp_cdr(x), context); @@ -343,8 +347,16 @@ static sexp analyze (sexp x, sexp context) { } static sexp analyze_lambda (sexp x, sexp context) { - sexp res, body; - /* XXXX verify syntax */ + sexp res, body, ls, tmp, name, value, defs=SEXP_NULL; + /* verify syntax */ + if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) + return sexp_compile_error("bad lambda syntax", sexp_list1(x)); + for (ls=sexp_cadr(x); sexp_pairp(ls); ls=sexp_cdr(ls)) + if (! sexp_symbolp(sexp_car(ls))) + return sexp_compile_error("non-symbol parameter", sexp_list1(x)); + else if (sexp_memq(sexp_car(ls), sexp_cdr(ls)) != SEXP_FALSE) + return sexp_compile_error("duplicate parameter", sexp_list1(x)); + /* build lambda and analyze body */ res = sexp_make_lambda(sexp_cadr(x)); context = sexp_child_context(context, res); sexp_context_env(context) @@ -354,6 +366,29 @@ static sexp analyze_lambda (sexp x, sexp context) { sexp_env_lambda(sexp_context_env(context)) = res; body = analyze_seq(sexp_cddr(x), context); analyze_check_exception(body); + /* delayed analyze internal defines */ + for (ls=sexp_lambda_defs(res); sexp_pairp(ls); ls=sexp_cdr(ls)) { + tmp = sexp_car(ls); + if (sexp_pairp(sexp_cadr(tmp))) { + name = sexp_caadr(tmp); + value = analyze_lambda(sexp_cons(SEXP_UNDEF, sexp_cons(sexp_cdadr(tmp), + sexp_cddr(tmp))), + context); + } else { + name = sexp_cadr(tmp); + value = analyze(sexp_caddr(tmp), context); + } + analyze_check_exception(value); + sexp_push(defs, sexp_make_set(analyze_var_ref(name, context), value)); + } + if (sexp_pairp(defs)) { + if (! sexp_seqp(body)) { + tmp = sexp_alloc_type(seq, SEXP_SEQ); + sexp_seq_ls(tmp) = sexp_list1(body); + body = tmp; + } + sexp_seq_ls(body) = sexp_append(defs, sexp_seq_ls(body)); + } sexp_lambda_body(res) = body; return res; } @@ -394,8 +429,16 @@ static sexp analyze_app (sexp x, sexp context) { static sexp analyze_define (sexp x, sexp context) { sexp ref, name, value, env = sexp_context_env(context); name = (sexp_pairp(sexp_cadr(x)) ? sexp_caadr(x) : sexp_cadr(x)); - if (sexp_env_lambda(env) && sexp_lambdap(sexp_env_lambda(env))) + if (sexp_env_lambda(env) && sexp_lambdap(sexp_env_lambda(env))) { + sexp_push(sexp_env_bindings(env), + sexp_cons(name, sexp_context_lambda(context))); + sexp_push(sexp_lambda_sv(sexp_env_lambda(env)), name); sexp_push(sexp_lambda_locals(sexp_env_lambda(env)), name); + sexp_push(sexp_lambda_defs(sexp_env_lambda(env)), x); + return SEXP_UNDEF; + } else { + env_cell_create(env, name, SEXP_DEF); + } if (sexp_pairp(sexp_cadr(x))) value = analyze_lambda(sexp_cons(SEXP_UNDEF, sexp_cons(sexp_cdadr(x), sexp_cddr(x))), @@ -405,7 +448,6 @@ static sexp analyze_define (sexp x, sexp context) { analyze_check_exception(value); ref = analyze_var_ref(name, context); analyze_check_exception(ref); - env_cell_create(env, name, SEXP_DEF); return sexp_make_set(ref, value); } @@ -502,11 +544,12 @@ static void generate_seq (sexp app, sexp context) { sexp head=app, tail=sexp_cdr(app); sexp_uint_t tailp = sexp_context_tailp(context); sexp_context_tailp(context) = 0; - for ( ; sexp_pairp(tail); head=tail, tail=sexp_cdr(tail)) { - generate(sexp_car(head), context); - emit(OP_DROP, context); - sexp_context_depth(context)--; - } + for ( ; sexp_pairp(tail); head=tail, tail=sexp_cdr(tail)) + if (sexp_pointerp(sexp_car(head)) && (! sexp_litp(sexp_car(head)))) { + generate(sexp_car(head), context); + emit(OP_DROP, context); + sexp_context_depth(context)--; + } sexp_context_tailp(context) = tailp; generate(sexp_car(head), context); } @@ -565,18 +608,26 @@ static void generate_non_global_ref (sexp name, sexp cell, sexp lambda, } static void generate_set (sexp set, sexp context) { - sexp ref = sexp_set_var(set); + sexp ref = sexp_set_var(set), lambda; /* compile the value */ sexp_context_tailp(context) = 0; generate(sexp_set_value(set), context); if (! sexp_lambdap(sexp_ref_loc(ref))) { /* global vars are set directly */ emit_push(sexp_ref_cell(ref), context); + emit(OP_SET_CDR, context); } else { - /* stack or closure mutable vars are boxed */ - generate_ref(ref, context, 0); + lambda = sexp_ref_loc(ref); + if (sexp_memq(sexp_ref_name(ref), sexp_lambda_sv(lambda)) != SEXP_FALSE) { + /* stack or closure mutable vars are boxed */ + generate_ref(ref, context, 0); + emit(OP_SET_CDR, context); + } else { + /* internally defined variable */ + emit(OP_LOCAL_SET, context); + emit_word(sexp_param_index(lambda, sexp_ref_name(ref)), context); + } } - emit(OP_SET_CDR, context); sexp_context_depth(context)--; } @@ -846,6 +897,7 @@ sexp vm(sexp bc, sexp cp, sexp e, sexp* stack, sexp_sint_t top) { sexp_sint_t i, j, k, fp=top-4; loop: + /* print_stack(stack, top, fp); */ /* fprintf(stderr, "%s\n", (*ip<=71)?reverse_opcode_names[*ip]:"UNKNOWN"); */ switch (*ip++) { case OP_NOOP: diff --git a/sexp.c b/sexp.c index fc82f1bb..2ea80cf9 100644 --- a/sexp.c +++ b/sexp.c @@ -130,6 +130,8 @@ sexp sexp_print_exception(sexp exn, sexp out) { sexp_write_string("\n", out); } } + } else { + sexp_write_string("\n", out); } return SEXP_UNDEF; } diff --git a/sexp.h b/sexp.h index 71dabe48..bd4f6283 100644 --- a/sexp.h +++ b/sexp.h @@ -134,7 +134,7 @@ struct sexp_struct { } core; /* ast types */ struct { - sexp name, params, locals, flags, body, fv, sv; + sexp name, params, locals, defs, flags, body, fv, sv; } lambda; struct { sexp test, pass, fail; @@ -298,6 +298,7 @@ struct sexp_struct { #define sexp_lambda_name(x) ((x)->value.lambda.name) #define sexp_lambda_params(x) ((x)->value.lambda.params) #define sexp_lambda_locals(x) ((x)->value.lambda.locals) +#define sexp_lambda_defs(x) ((x)->value.lambda.defs) #define sexp_lambda_flags(x) ((x)->value.lambda.flags) #define sexp_lambda_body(x) ((x)->value.lambda.body) #define sexp_lambda_fv(x) ((x)->value.lambda.fv) From b599eab54d99d2caa9bfffe7b785c7ddb8a1bb6a Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 31 Mar 2009 20:18:10 +0900 Subject: [PATCH 072/154] trimming opcodes --- debug.c | 9 +++-- eval.c | 107 +++++++++++++++++++++++++++++-------------------------- eval.h | 7 +--- init.scm | 2 +- 4 files changed, 65 insertions(+), 60 deletions(-) diff --git a/debug.c b/debug.c index bd1593a8..6238810a 100644 --- a/debug.c +++ b/debug.c @@ -7,8 +7,8 @@ static const char* reverse_opcode_names[] = "FCALL0", "FCALL1", "FCALL2", "FCALL3", "EVAL", "JUMP_UNLESS", "JUMP", "PUSH", "DROP", "STACK_REF", "LOCAL_REF", "LOCAL_SET", "CLOSURE_REF", "VECTOR_REF", "VECTOR_SET", "STRING_REF", "STRING_SET", - "MAKE_PROCEDURE", "MAKE_VECTOR", "PAIRP", "NULLP", "VECTORP", "INTEGERP", - "SYMBOLP", "STRINGP", "CHARP", "EOFP", "PROCEDUREP", "IPORTP", "OPORTP", + "MAKE_PROCEDURE", "MAKE_VECTOR", "NULLP", "INTEGERP", + "SYMBOLP", "CHARP", "EOFP", "TYPEP", "CAR", "CDR", "SET_CAR", "SET_CDR", "CONS", "ADD", "SUB", "MUL", "DIV", "QUOT", "MOD", "NEG", "INV", "LT", "LE", "EQV", "EQ", "DISPLAY", "WRITE", "WRITE_CHAR", "NEWLINE", "FLUSH_OUTPUT", "READ", "READ_CHAR", "RET", "DONE", @@ -30,6 +30,11 @@ void disasm (sexp bc) { case OP_CLOSURE_REF: case OP_JUMP: case OP_JUMP_UNLESS: + case OP_FCALL0: + case OP_FCALL1: + case OP_FCALL2: + case OP_FCALL3: + case OP_TYPEP: fprintf(stderr, "%ld", (sexp_sint_t) ((sexp*)ip)[0]); ip += sizeof(sexp); break; diff --git a/eval.c b/eval.c index 1a452840..b5521c69 100644 --- a/eval.c +++ b/eval.c @@ -662,20 +662,23 @@ static void generate_opcode_app (sexp app, sexp context) { generate(sexp_car(ls), context); /* emit the actual operator call */ - if (sexp_opcode_class(op) == OPC_ARITHMETIC_INV) { + switch (sexp_opcode_class(op)) { + case OPC_ARITHMETIC_INV: emit((num_args == 1) ? sexp_opcode_inverse(op) : sexp_opcode_code(op), context); - } else { - if (sexp_opcode_class(op) == OPC_FOREIGN) { - /* push the funtion pointer for foreign calls */ - emit_push(sexp_opcode_data(op), context); - emit(sexp_opcode_code(op), context); - } else if (sexp_opcode_class(op) == OPC_PARAMETER) { - emit_push(sexp_opcode_data(op), context); - emit(OP_CDR, context); - } else { - emit(sexp_opcode_code(op), context); - } + break; + case OPC_FOREIGN: + case OPC_TYPE_PREDICATE: + /* push the funtion pointer for foreign calls */ + emit(sexp_opcode_code(op), context); + if (sexp_opcode_data(op)) + emit_word((sexp_uint_t)sexp_opcode_data(op), context); + break; + case OPC_PARAMETER: + emit_push(sexp_opcode_data(op), context); + emit(OP_CDR, context); + default: + emit(sexp_opcode_code(op), context); } /* emit optional folding of operator */ @@ -887,9 +890,14 @@ static sexp_uint_t sexp_restore_stack(sexp saved, sexp *current) { #define _ARG4 stack[top-4] #define _ARG5 stack[top-5] #define _PUSH(x) (stack[top++]=(x)) -#define _POP() (stack[--top]) +#define _WORD0 ((sexp*)ip)[0] +#define _UWORD0 ((sexp_uint_t*)ip)[0] +#define _SWORD0 ((sexp_sint_t*)ip)[0] -#define sexp_raise(msg, args) do {stack[top]=sexp_compile_error(msg, args); top++; goto call_error_handler;} while (0) +#define sexp_raise(msg, args) do {stack[top]=sexp_compile_error(msg, args); \ + top++; \ + goto call_error_handler;} \ + while (0) sexp vm(sexp bc, sexp cp, sexp e, sexp* stack, sexp_sint_t top) { unsigned char *ip=sexp_bytecode_data(bc); @@ -952,7 +960,7 @@ sexp vm(sexp bc, sexp cp, sexp e, sexp* stack, sexp_sint_t top) { ip -= sizeof(sexp); goto make_call; case OP_TAIL_CALL: - i = sexp_unbox_integer(((sexp*)ip)[0]); /* number of params */ + i = sexp_unbox_integer(_WORD0); /* number of params */ tmp1 = _ARG1; /* procedure to call */ /* save frame info */ j = sexp_unbox_integer(stack[fp]); @@ -967,7 +975,7 @@ sexp vm(sexp bc, sexp cp, sexp e, sexp* stack, sexp_sint_t top) { case OP_CALL: if (top >= INIT_STACK_SIZE) sexp_raise("out of stack space", SEXP_NULL); - i = sexp_unbox_integer(((sexp*)ip)[0]); + i = sexp_unbox_integer(_WORD0); tmp1 = _ARG1; make_call: if (sexp_opcodep(tmp1)) { @@ -1014,57 +1022,60 @@ sexp vm(sexp bc, sexp cp, sexp e, sexp* stack, sexp_sint_t top) { fp = top-4; break; case OP_FCALL0: - _ARG1 = ((sexp_proc0)_ARG1)(); + _PUSH(((sexp_proc0)_UWORD0)()); + ip += sizeof(sexp); if (sexp_exceptionp(_ARG1)) goto call_error_handler; break; case OP_FCALL1: - _ARG2 = ((sexp_proc1)_ARG1)(_ARG2); - top--; + _ARG1 = ((sexp_proc1)_UWORD0)(_ARG1); + ip += sizeof(sexp); if (sexp_exceptionp(_ARG1)) goto call_error_handler; break; case OP_FCALL2: - _ARG3 = ((sexp_proc2)_ARG1)(_ARG2, _ARG3); - top-=2; + _ARG2 = ((sexp_proc2)_UWORD0)(_ARG1, _ARG2); + top--; + ip += sizeof(sexp); if (sexp_exceptionp(_ARG1)) goto call_error_handler; break; case OP_FCALL3: - _ARG4 =((sexp_proc3)_ARG1)(_ARG2, _ARG3, _ARG4); - top-=3; + _ARG3 =((sexp_proc3)_UWORD0)(_ARG1, _ARG2, _ARG3); + top-=2; + ip += sizeof(sexp); if (sexp_exceptionp(_ARG1)) goto call_error_handler; break; case OP_JUMP_UNLESS: if (stack[--top] == SEXP_FALSE) - ip += ((sexp_sint_t*)ip)[0]; + ip += _SWORD0; else ip += sizeof(sexp_sint_t); break; case OP_JUMP: - ip += ((sexp_sint_t*)ip)[0]; + ip += _SWORD0; break; case OP_PUSH: - _PUSH(((sexp*)ip)[0]); + _PUSH(_WORD0); ip += sizeof(sexp); break; case OP_DROP: top--; break; case OP_STACK_REF: /* `pick' in forth */ - stack[top] = stack[top - (sexp_sint_t) ((sexp*)ip)[0]]; + stack[top] = stack[top - _SWORD0]; ip += sizeof(sexp); top++; break; case OP_LOCAL_REF: - stack[top] = stack[fp - 1 - (sexp_sint_t) ((sexp*)ip)[0]]; + stack[top] = stack[fp - 1 - _SWORD0]; ip += sizeof(sexp); top++; break; case OP_LOCAL_SET: - stack[fp - 1 - (sexp_sint_t) ((sexp*)ip)[0]] = _ARG1; + stack[fp - 1 - _SWORD0] = _ARG1; _ARG1 = SEXP_UNDEF; ip += sizeof(sexp); break; case OP_CLOSURE_REF: - _PUSH(sexp_vector_ref(cp, sexp_make_integer(((sexp*)ip)[0]))); + _PUSH(sexp_vector_ref(cp, sexp_make_integer(_WORD0))); ip += sizeof(sexp); break; case OP_VECTOR_REF: @@ -1097,28 +1108,22 @@ sexp vm(sexp bc, sexp cp, sexp e, sexp* stack, sexp_sint_t top) { _ARG2 = sexp_make_vector(_ARG1, _ARG2); top--; break; - case OP_PAIRP: - _ARG1 = sexp_make_boolean(sexp_pairp(_ARG1)); break; + case OP_EOFP: + _ARG1 = sexp_make_boolean(_ARG1 == SEXP_EOF); break; case OP_NULLP: _ARG1 = sexp_make_boolean(sexp_nullp(_ARG1)); break; - case OP_VECTORP: - _ARG1 = sexp_make_boolean(sexp_vectorp(_ARG1)); break; case OP_INTEGERP: _ARG1 = sexp_make_boolean(sexp_integerp(_ARG1)); break; case OP_SYMBOLP: _ARG1 = sexp_make_boolean(sexp_symbolp(_ARG1)); break; - case OP_STRINGP: - _ARG1 = sexp_make_boolean(sexp_stringp(_ARG1)); break; case OP_CHARP: _ARG1 = sexp_make_boolean(sexp_charp(_ARG1)); break; - case OP_EOFP: - _ARG1 = sexp_make_boolean(_ARG1 == SEXP_EOF); break; - case OP_PROCEDUREP: - _ARG1 = sexp_make_boolean(sexp_procedurep(_ARG1)); break; - case OP_IPORTP: - _ARG1 = sexp_make_boolean(sexp_iportp(_ARG1)); break; - case OP_OPORTP: - _ARG1 = sexp_make_boolean(sexp_oportp(_ARG1)); break; + case OP_TYPEP: + _ARG1 = sexp_make_boolean(sexp_pointerp(_ARG1) + && (sexp_pointer_tag(_ARG1) + == _UWORD0)); + ip += sizeof(sexp); + break; case OP_CAR: if (! sexp_pairp(_ARG1)) sexp_raise("car: not a pair", sexp_list1(_ARG1)); _ARG1 = sexp_car(_ARG1); break; @@ -1404,16 +1409,16 @@ _OP(OPC_PREDICATE, OP_EQ, 2, 0, 0, 0, 0, "eq?", NULL, NULL), _OP(OPC_CONSTRUCTOR, OP_CONS, 2, 0, 0, 0, 0, "cons", NULL, NULL), _OP(OPC_CONSTRUCTOR, OP_MAKE_VECTOR, 2, 0, SEXP_FIXNUM, 0, 0, "make-vector", NULL, NULL), _OP(OPC_CONSTRUCTOR, OP_MAKE_PROCEDURE, 4, 0, 0, 0, 0, "make-procedure", NULL, NULL), -_OP(OPC_TYPE_PREDICATE, OP_PAIRP, 1, 0, 0, 0, 0, "pair?", NULL, NULL), _OP(OPC_TYPE_PREDICATE, OP_NULLP, 1, 0, 0, 0, 0, "null?", NULL, NULL), -_OP(OPC_TYPE_PREDICATE, OP_STRINGP, 1, 0, 0, 0, 0, "string?", NULL, NULL), +_OP(OPC_TYPE_PREDICATE, OP_EOFP, 1, 0, 0, 0, 0, "eof-object?", NULL, NULL), _OP(OPC_TYPE_PREDICATE, OP_SYMBOLP, 1, 0, 0, 0, 0, "symbol?", NULL, NULL), _OP(OPC_TYPE_PREDICATE, OP_CHARP, 1, 0, 0, 0, 0, "char?", NULL, NULL), -_OP(OPC_TYPE_PREDICATE, OP_VECTORP, 1, 0, 0, 0, 0, "vector?", NULL, NULL), -_OP(OPC_TYPE_PREDICATE, OP_PROCEDUREP, 1, 0, 0, 0, 0, "procedure?", NULL, NULL), -_OP(OPC_TYPE_PREDICATE, OP_IPORTP, 1, 0, 0, 0, 0, "input-port?", NULL, NULL), -_OP(OPC_TYPE_PREDICATE, OP_OPORTP, 1, 0, 0, 0, 0, "output-port?", NULL, NULL), -_OP(OPC_TYPE_PREDICATE, OP_EOFP, 1, 0, 0, 0, 0, "eof-object?", NULL, NULL), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "pair?", (sexp)SEXP_PAIR, NULL), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "string?", (sexp)SEXP_STRING, NULL), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "vector?", (sexp)SEXP_VECTOR, NULL), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "procedure?", (sexp)SEXP_PROCEDURE, NULL), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "input-port?", (sexp)SEXP_IPORT, NULL), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "output-port?", (sexp)SEXP_OPORT, NULL), _OP(OPC_GENERIC, OP_APPLY1, 2, 0, SEXP_PROCEDURE, SEXP_PAIR, 0, "apply1", NULL, NULL), _OP(OPC_GENERIC, OP_CALLCC, 1, SEXP_PROCEDURE, 0, 0, 0, "call-with-current-continuation", NULL, NULL), _OP(OPC_GENERIC, OP_ERROR, 1, SEXP_STRING, 0, 0, 0, "error", NULL, NULL), diff --git a/eval.h b/eval.h index 3648d36d..1062ed9c 100644 --- a/eval.h +++ b/eval.h @@ -83,17 +83,12 @@ enum opcode_names { OP_STRING_SET, OP_MAKE_PROCEDURE, OP_MAKE_VECTOR, - OP_PAIRP, OP_NULLP, - OP_VECTORP, OP_INTEGERP, OP_SYMBOLP, - OP_STRINGP, OP_CHARP, OP_EOFP, - OP_PROCEDUREP, - OP_IPORTP, - OP_OPORTP, + OP_TYPEP, OP_CAR, OP_CDR, OP_SET_CAR, diff --git a/init.scm b/init.scm index 95ea7c97..57ad724e 100644 --- a/init.scm +++ b/init.scm @@ -1,6 +1,6 @@ ;; let* cond case delay and do -;; quasiquote unquote unquote-splicing let-syntax +;; quasiquote let-syntax ;; letrec-syntax syntax-rules eqv? equal? not boolean? number? ;; complex? real? rational? integer? exact? inexact? ;; positive? negative? odd? even? max min quotient remainder From a0c78ad611dc61588209cd72bed12091add07f1d Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 31 Mar 2009 21:52:26 +0900 Subject: [PATCH 073/154] removing use of global variables --- Makefile | 2 +- debug.c | 21 +++---- eval.c | 182 +++++++++++++++++++++++++++++++++++-------------------- init.scm | 2 + sexp.c | 1 + sexp.h | 2 +- 6 files changed, 130 insertions(+), 80 deletions(-) diff --git a/Makefile b/Makefile index 93c552a4..b3bc5e7b 100644 --- a/Makefile +++ b/Makefile @@ -3,7 +3,7 @@ all: chibi-scheme -CFLAGS=-Wall -g -fno-inline -save-temps -Os +CFLAGS=-Wall -g -fno-inline -save-temps #-Os GC_OBJ=./gc/gc.a diff --git a/debug.c b/debug.c index 6238810a..fee2f48b 100644 --- a/debug.c +++ b/debug.c @@ -14,14 +14,14 @@ static const char* reverse_opcode_names[] = "WRITE_CHAR", "NEWLINE", "FLUSH_OUTPUT", "READ", "READ_CHAR", "RET", "DONE", }; -void disasm (sexp bc) { +void disasm (sexp bc, sexp out) { unsigned char *ip=sexp_bytecode_data(bc), opcode; loop: opcode = *ip++; if (opcode*sizeof(char*) < sizeof(reverse_opcode_names)) { - fprintf(stderr, " %s ", reverse_opcode_names[opcode]); + sexp_printf(out, " %s ", reverse_opcode_names[opcode]); } else { - fprintf(stderr, " %d ", opcode); + sexp_printf(out, " %d ", opcode); } switch (opcode) { case OP_STACK_REF: @@ -35,17 +35,17 @@ void disasm (sexp bc) { case OP_FCALL2: case OP_FCALL3: case OP_TYPEP: - fprintf(stderr, "%ld", (sexp_sint_t) ((sexp*)ip)[0]); + sexp_printf(out, "%ld", (sexp_sint_t) ((sexp*)ip)[0]); ip += sizeof(sexp); break; case OP_TAIL_CALL: case OP_CALL: case OP_PUSH: - sexp_write(((sexp*)ip)[0], cur_error_port); + sexp_write(((sexp*)ip)[0], out); ip += sizeof(sexp); break; } - fprintf(stderr, "\n"); + sexp_write_char('\n', out); if (ip - sexp_bytecode_data(bc) < sexp_bytecode_length(bc)) goto loop; } @@ -75,13 +75,12 @@ void print_bytecode (sexp bc) { } } -void print_stack (sexp *stack, int top, int fp) { +void print_stack (sexp *stack, int top, int fp, sexp out) { int i; for (i=0; i ", x); goto loop; } else if (sexp_opcodep(op)) { res = analyze_app(sexp_cdr(x), context); @@ -500,7 +513,10 @@ static void sexp_context_patch_label (sexp context, sexp_sint_t label) { static sexp finalize_bytecode (sexp context) { emit(OP_RET, context); shrink_bcode(context, sexp_context_pos(context)); - disasm(sexp_context_bc(context)); + disasm(sexp_context_bc(context), + env_global_ref(sexp_context_env(context), + the_cur_err_symbol, + SEXP_FALSE)); return sexp_context_bc(context); } @@ -721,7 +737,8 @@ static void generate_lambda (sexp lambda, sexp context) { prev_lambda = sexp_context_lambda(context); prev_fv = sexp_lambdap(prev_lambda) ? sexp_lambda_fv(prev_lambda) : SEXP_NULL; fv = sexp_lambda_fv(lambda); - ctx = sexp_new_context(sexp_context_stack(context)); + ctx = sexp_make_context(sexp_context_stack(context), + sexp_context_env(context)); sexp_context_lambda(ctx) = lambda; /* allocate space for local vars */ for (ls=sexp_lambda_locals(lambda); sexp_pairp(ls); ls=sexp_cdr(ls)) @@ -845,12 +862,11 @@ static sexp make_opcode_procedure (sexp op, sexp_uint_t i, sexp env, if (i == sexp_opcode_num_args(op) && sexp_opcode_proc(op)) return sexp_opcode_proc(op); params = make_param_list(i); - context = sexp_new_context(stack); lambda = sexp_make_lambda(params); + env = extend_env(env, params, lambda); + context = sexp_make_context(stack, env); sexp_context_lambda(context) = lambda; sexp_context_top(context) = top; - env = extend_env(env, params, lambda); - sexp_context_env(context) = env; for (ls=params, refs=SEXP_NULL; sexp_pairp(ls); ls=sexp_cdr(ls)) sexp_push(refs, sexp_make_ref(sexp_car(ls), env_cell(env, sexp_car(ls)))); generate_opcode_app(sexp_cons(op, sexp_reverse(refs)), context); @@ -899,9 +915,13 @@ static sexp_uint_t sexp_restore_stack(sexp saved, sexp *current) { goto call_error_handler;} \ while (0) -sexp vm(sexp bc, sexp cp, sexp e, sexp* stack, sexp_sint_t top) { +#define sexp_check_exception() do {if (sexp_exceptionp(_ARG1)) \ + goto call_error_handler;} \ + while (0) + +sexp vm(sexp bc, sexp cp, sexp context, sexp* stack, sexp_sint_t top) { unsigned char *ip=sexp_bytecode_data(bc); - sexp tmp1, tmp2; + sexp tmp1, tmp2, env=sexp_context_env(context); sexp_sint_t i, j, k, fp=top-4; loop: @@ -913,12 +933,13 @@ sexp vm(sexp bc, sexp cp, sexp e, sexp* stack, sexp_sint_t top) { break; case OP_ERROR: call_error_handler: - sexp_print_exception(_ARG1, cur_error_port); - tmp1 = sexp_cdr(exception_handler_cell); + tmp1 = env_global_ref(env, the_cur_err_symbol, SEXP_FALSE); + sexp_print_exception(_ARG1, tmp1); + tmp1 = env_global_ref(env, the_err_handler_symbol, SEXP_FALSE); stack[top] = (sexp) 1; stack[top+1] = sexp_make_integer(ip+4); stack[top+2] = cp; - top+=3; + top += 3; bc = sexp_procedure_code(tmp1); ip = sexp_bytecode_data(bc); cp = sexp_procedure_vars(tmp1); @@ -980,7 +1001,7 @@ sexp vm(sexp bc, sexp cp, sexp e, sexp* stack, sexp_sint_t top) { make_call: if (sexp_opcodep(tmp1)) { /* compile non-inlined opcode applications on the fly */ - tmp1 = make_opcode_procedure(tmp1, i, e, stack, top); + tmp1 = make_opcode_procedure(tmp1, i, env, stack, top); if (sexp_exceptionp(tmp1)) { _ARG1 = tmp1; goto call_error_handler; @@ -1015,7 +1036,7 @@ sexp vm(sexp bc, sexp cp, sexp e, sexp* stack, sexp_sint_t top) { stack[top] = sexp_make_integer(ip+sizeof(sexp)); stack[top+1] = cp; stack[top+2] = sexp_make_integer(fp); - top+=3; + top += 3; bc = sexp_procedure_code(tmp1); ip = sexp_bytecode_data(bc); cp = sexp_procedure_vars(tmp1); @@ -1024,24 +1045,29 @@ sexp vm(sexp bc, sexp cp, sexp e, sexp* stack, sexp_sint_t top) { case OP_FCALL0: _PUSH(((sexp_proc0)_UWORD0)()); ip += sizeof(sexp); - if (sexp_exceptionp(_ARG1)) goto call_error_handler; + sexp_check_exception(); break; case OP_FCALL1: _ARG1 = ((sexp_proc1)_UWORD0)(_ARG1); ip += sizeof(sexp); - if (sexp_exceptionp(_ARG1)) goto call_error_handler; + sexp_check_exception(); break; case OP_FCALL2: _ARG2 = ((sexp_proc2)_UWORD0)(_ARG1, _ARG2); top--; ip += sizeof(sexp); - if (sexp_exceptionp(_ARG1)) goto call_error_handler; + sexp_check_exception(); break; case OP_FCALL3: _ARG3 =((sexp_proc3)_UWORD0)(_ARG1, _ARG2, _ARG3); - top-=2; + top -= 2; ip += sizeof(sexp); - if (sexp_exceptionp(_ARG1)) goto call_error_handler; + sexp_check_exception(); + break; + case OP_EVAL: + sexp_context_top(context) = top; + _ARG1 = eval_in_context(_ARG1, context); + sexp_check_exception(); break; case OP_JUMP_UNLESS: if (stack[--top] == SEXP_FALSE) @@ -1278,7 +1304,7 @@ sexp vm(sexp bc, sexp cp, sexp e, sexp* stack, sexp_sint_t top) { break; case OP_READ: _ARG1 = sexp_read(_ARG1); - if (sexp_exceptionp(_ARG1)) goto call_error_handler; + sexp_check_exception(); break; case OP_READ_CHAR: i = sexp_read_char(_ARG1); @@ -1318,9 +1344,8 @@ sexp sexp_close_port (sexp port) { return SEXP_UNDEF; } -sexp sexp_load (sexp source) { - sexp obj, res, in, context = sexp_new_context(NULL); - sexp_context_env(context) = interaction_environment; +sexp sexp_load (sexp source, sexp env) { + sexp obj, res, in, context = sexp_make_context(NULL, env); in = sexp_open_input_file(source); while ((obj=sexp_read(in)) != (sexp) SEXP_EOF) { res = eval_in_context(obj, context); @@ -1361,6 +1386,7 @@ define_math_op(sexp_tan, tan) define_math_op(sexp_asin, asin) define_math_op(sexp_acos, acos) define_math_op(sexp_atan, atan) +define_math_op(sexp_sqrt, sqrt) #endif @@ -1429,6 +1455,7 @@ _OP(OPC_IO, OP_NEWLINE, 0, 3, 0, SEXP_OPORT, 0, "newline", (sexp)"*current-outpu _OP(OPC_IO, OP_FLUSH_OUTPUT, 0, 3, 0, SEXP_OPORT, 0, "flush-output", (sexp)"*current-output-port*", NULL), _OP(OPC_IO, OP_READ, 0, 3, 0, SEXP_IPORT, 0, "read", (sexp)"*current-input-port*", NULL), _OP(OPC_IO, OP_READ_CHAR, 0, 3, 0, SEXP_IPORT, 0, "read-char", (sexp)"*current-input-port*", NULL), +_OP(OPC_GENERIC, OP_EVAL, 1, 3, 0, 0, 0, "eval", (sexp)"*interaction-environment*", NULL), _FN1(0, "identifier?", sexp_identifierp), _FN1(SEXP_PAIR, "length", sexp_length), _FN1(SEXP_PAIR, "reverse", sexp_reverse), @@ -1437,7 +1464,9 @@ _FN1(SEXP_STRING, "open-input-file", sexp_open_input_file), _FN1(SEXP_STRING, "open-output-file", sexp_open_output_file), _FN1(SEXP_IPORT, "close-input-port", sexp_close_port), _FN1(SEXP_OPORT, "close-output-port", sexp_close_port), -_FN1(0, "load", sexp_load), +_FN1(SEXP_FIXNUM, "null-environment", sexp_make_null_env), +_FN1(SEXP_FIXNUM, "scheme-report-environment", sexp_make_standard_env), +_FN2(0, SEXP_ENV, "%load", sexp_load), #if USE_MATH _FN1(0, "exp", sexp_exp), _FN1(0, "log", sexp_log), @@ -1447,6 +1476,7 @@ _FN1(0, "tan", sexp_tan), _FN1(0, "asin", sexp_asin), _FN1(0, "acos", sexp_acos), _FN1(0, "atan", sexp_atan), +_FN1(0, "sqrt", sexp_sqrt), #endif _FN2(0, SEXP_PAIR, "memq", sexp_memq), _FN2(0, SEXP_PAIR, "assq", sexp_assq), @@ -1458,22 +1488,36 @@ _PARAM("current-error-handler", (sexp)"*current-error-handler*", SEXP_PROCEDURE) _PARAM("interaction-environment", (sexp)"*interaction-environment*", SEXP_ENV), }; -sexp make_standard_env () { +static sexp standard_env_syms_interned_p = 0; + +static sexp sexp_make_null_env (sexp version) { sexp_uint_t i; sexp e = sexp_alloc_type(env, SEXP_ENV); sexp_env_parent(e) = NULL; sexp_env_bindings(e) = SEXP_NULL; for (i=0; i<(sizeof(core_forms)/sizeof(core_forms[0])); i++) env_define(e, sexp_intern(sexp_core_name(&core_forms[i])), &core_forms[i]); + return e; +} + +static sexp sexp_make_standard_env (sexp version) { + sexp_uint_t i; + sexp e = sexp_make_null_env(version), cell, sym; for (i=0; i<(sizeof(opcodes)/sizeof(opcodes[0])); i++) { - if (sexp_opcode_opt_param_p(&opcodes[i]) - && sexp_opcode_data(&opcodes[i])) - sexp_opcode_data(&opcodes[i]) - = env_cell_create(e, - sexp_intern((char*)sexp_opcode_data(&opcodes[i])), - SEXP_UNDEF); + if ((! standard_env_syms_interned_p) + && sexp_opcode_opt_param_p(&opcodes[i]) + && sexp_opcode_data(&opcodes[i])) { + sym = sexp_intern((char*)sexp_opcode_data(&opcodes[i])); + cell = env_cell_create(e, sym, SEXP_UNDEF); + sexp_opcode_data(&opcodes[i]) = cell; + } env_define(e, sexp_intern(sexp_opcode_name(&opcodes[i])), &opcodes[i]); } + env_define(e, the_cur_in_symbol, sexp_make_input_port(stdin)); + env_define(e, the_cur_out_symbol, sexp_make_output_port(stdout)); + env_define(e, the_cur_err_symbol, sexp_make_output_port(stderr)); + env_define(e, the_interaction_env_symbol, e); + standard_env_syms_interned_p = 1; return e; } @@ -1493,7 +1537,7 @@ sexp apply(sexp proc, sexp args, sexp context) { stack[top++] = sexp_make_integer(0); return vm(sexp_procedure_code(proc), sexp_procedure_vars(proc), - sexp_context_env(context), + context, stack, top); } @@ -1502,7 +1546,8 @@ sexp compile (sexp x, sexp context) { sexp ast, ctx; analyze_bind(ast, x, context); free_vars(ast, SEXP_NULL); /* should return SEXP_NULL */ - ctx = sexp_new_context(sexp_context_stack(context)); + ctx = sexp_make_context(sexp_context_stack(context), + sexp_context_env(context)); generate(ast, ctx); return sexp_make_procedure(sexp_make_integer(0), sexp_make_integer(0), @@ -1513,14 +1558,16 @@ sexp compile (sexp x, sexp context) { sexp eval_in_context (sexp obj, sexp context) { sexp thunk = compile(obj, context); if (sexp_exceptionp(thunk)) { - sexp_print_exception(obj, cur_error_port); + sexp_print_exception(obj, env_global_ref(sexp_context_env(context), + the_cur_err_symbol, + SEXP_FALSE)); return SEXP_UNDEF; } return apply(thunk, SEXP_NULL, context); } sexp eval (sexp obj, sexp env) { - sexp context = sexp_new_context(NULL); + sexp context = sexp_make_context(NULL, NULL); sexp_context_env(context) = env; return eval_in_context(obj, context); } @@ -1530,11 +1577,13 @@ void scheme_init () { if (! scheme_initialized_p) { scheme_initialized_p = 1; sexp_init(); - cur_input_port = sexp_make_input_port(stdin); - cur_output_port = sexp_make_output_port(stdout); - cur_error_port = sexp_make_output_port(stderr); the_compile_error_symbol = sexp_intern("compile-error"); - context = sexp_new_context(NULL); + the_err_handler_symbol = sexp_intern("*current-error-handler*"); + the_cur_in_symbol = sexp_intern("*current-input-port*"); + the_cur_out_symbol = sexp_intern("*current-output-port*"); + the_cur_err_symbol = sexp_intern("*current-error-port*"); + the_interaction_env_symbol = sexp_intern("*interaction-environment*"); + context = sexp_make_context(NULL, NULL); emit(OP_RESUMECC, context); continuation_resumer = finalize_bytecode(context); context = sexp_child_context(context, NULL); @@ -1544,33 +1593,35 @@ void scheme_init () { } void repl (sexp context) { - sexp obj, res; + sexp obj, res, env, in, out, err; + env = sexp_context_env(context); + in = env_global_ref(env, the_cur_in_symbol, SEXP_FALSE); + out = env_global_ref(env, the_cur_out_symbol, SEXP_FALSE); + err = env_global_ref(env, the_cur_err_symbol, SEXP_FALSE); while (1) { - sexp_write_string("> ", cur_output_port); - sexp_flush(cur_output_port); - obj = sexp_read(cur_input_port); + sexp_write_string("> ", out); + sexp_flush(out); + obj = sexp_read(in); if (obj == SEXP_EOF) break; if (sexp_exceptionp(obj)) { - sexp_print_exception(obj, cur_error_port); + sexp_print_exception(obj, err); } else { res = eval_in_context(obj, context); if (res != SEXP_UNDEF) { - sexp_write(res, cur_output_port); - sexp_write_char('\n', cur_output_port); + sexp_write(res, out); + sexp_write_char('\n', out); } } } } void run_main (int argc, char **argv) { - sexp env, obj, res, context, err_handler, err_handler_sym; + sexp env, obj, out=NULL, res, context, err_handler; sexp_uint_t i, quit=0, init_loaded=0; - env = make_standard_env(); - interaction_environment = env; - context = sexp_new_context(NULL); - sexp_context_env(context) = env; + env = sexp_make_standard_env(sexp_make_integer(5)); + context = sexp_make_context(NULL, env); sexp_context_tailp(context) = 0; emit_push(SEXP_UNDEF, context); emit(OP_DONE, context); @@ -1578,12 +1629,7 @@ void run_main (int argc, char **argv) { sexp_make_integer(0), finalize_bytecode(context), sexp_make_vector(0, SEXP_UNDEF)); - err_handler_sym = sexp_intern("*current-error-handler*"); - env_define(env, err_handler_sym, err_handler); - env_define(env, sexp_intern("*current-input-port*"), cur_input_port); - env_define(env, sexp_intern("*current-output-port*"), cur_output_port); - env_define(env, sexp_intern("*current-error-port*"), cur_error_port); - exception_handler_cell = env_cell(env, err_handler_sym); + env_define(env, the_err_handler_symbol, err_handler); /* parse options */ for (i=1; i < argc && argv[i][0] == '-'; i++) { @@ -1591,14 +1637,16 @@ void run_main (int argc, char **argv) { case 'e': case 'p': if (! init_loaded) { - sexp_load(sexp_make_string(sexp_init_file)); + sexp_load(sexp_make_string(sexp_init_file), env); init_loaded = 1; } obj = sexp_read_from_string(argv[i+1]); res = eval_in_context(obj, context); if (argv[i][1] == 'p') { - sexp_write(res, cur_output_port); - sexp_write_char('\n', cur_output_port); + if (! out) + out = env_global_ref(env, the_cur_out_symbol, SEXP_FALSE); + sexp_write(res, out); + sexp_write_char('\n', out); } quit=1; i++; @@ -1613,10 +1661,10 @@ void run_main (int argc, char **argv) { if (! quit) { if (! init_loaded) - sexp_load(sexp_make_string(sexp_init_file)); + sexp_load(sexp_make_string(sexp_init_file), env); if (i < argc) for ( ; i < argc; i++) - sexp_load(sexp_make_string(argv[i])); + sexp_load(sexp_make_string(argv[i]), env); else repl(context); } diff --git a/init.scm b/init.scm index 57ad724e..1e6587de 100644 --- a/init.scm +++ b/init.scm @@ -170,3 +170,5 @@ ;; (define (lcm a b) ;; (quotient (* a b) (gcd a b))) +(define (load file) (%load file (interaction-environment))) + diff --git a/sexp.c b/sexp.c index 2ea80cf9..5c5efb76 100644 --- a/sexp.c +++ b/sexp.c @@ -553,6 +553,7 @@ void sexp_write (sexp obj, sexp out) { sexp_write_string("#f", out); break; case (sexp_uint_t) SEXP_EOF: sexp_write_string("#", out); break; + case (sexp_uint_t) SEXP_DEF: case (sexp_uint_t) SEXP_UNDEF: sexp_write_string("#", out); break; case (sexp_uint_t) SEXP_ERROR: diff --git a/sexp.h b/sexp.h index bd4f6283..81f26e7d 100644 --- a/sexp.h +++ b/sexp.h @@ -386,7 +386,7 @@ int sstream_close(void *vec); #define sexp_push_char(c, p) (ungetc(c, sexp_port_stream(p))) #define sexp_write_char(c, p) (putc(c, sexp_port_stream(p))) #define sexp_write_string(s, p) (fputs(s, sexp_port_stream(p))) -#define sexp_printf(p, s, ...) (fprintf(sexp_port_stream(p), s, __VA_ARGS__)) +#define sexp_printf(p, ...) (fprintf(sexp_port_stream(p), __VA_ARGS__)) #define sexp_flush(p) (fflush(sexp_port_stream(p))) #else sexp sexp_read_char(sexp port); From 63d337491acb11c0263230b2fd33d2bb51ad9e71 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Wed, 1 Apr 2009 02:44:53 +0900 Subject: [PATCH 074/154] adding explicit renaming macros and a bunch of library code --- Makefile | 2 +- debug.c | 14 +++--- eval.c | 140 ++++++++++++++++-------------------------------------- eval.h | 1 + init.scm | 135 +++++++++++++++++++++++++++++++++++++++------------- opcodes.c | 90 +++++++++++++++++++++++++++++++++++ sexp.c | 76 ++++++++++++++++++++++------- sexp.h | 6 +-- 8 files changed, 305 insertions(+), 159 deletions(-) create mode 100644 opcodes.c diff --git a/Makefile b/Makefile index b3bc5e7b..c40baa06 100644 --- a/Makefile +++ b/Makefile @@ -13,7 +13,7 @@ GC_OBJ=./gc/gc.a sexp.o: sexp.c sexp.h config.h defaults.h Makefile gcc -c $(CFLAGS) -o $@ $< -eval.o: eval.c debug.c eval.h sexp.h config.h defaults.h Makefile +eval.o: eval.c debug.c opcodes.c eval.h sexp.h config.h defaults.h Makefile gcc -c $(CFLAGS) -o $@ $< # main.o: main.c eval.h sexp.h config.h Makefile diff --git a/debug.c b/debug.c index fee2f48b..052d2412 100644 --- a/debug.c +++ b/debug.c @@ -4,14 +4,14 @@ static const char* reverse_opcode_names[] = {"NOOP", "ERROR", "RESUMECC", "CALLCC", "APPLY1", "TAIL_CALL", "CALL", - "FCALL0", "FCALL1", "FCALL2", "FCALL3", "EVAL", "JUMP_UNLESS", "JUMP", - "PUSH", "DROP", "STACK_REF", "LOCAL_REF", "LOCAL_SET", + "FCALL0", "FCALL1", "FCALL2", "FCALL3", "FCALL4", "EVAL", "JUMP_UNLESS", + "JUMP", "PUSH", "DROP", "STACK_REF", "LOCAL_REF", "LOCAL_SET", "CLOSURE_REF", "VECTOR_REF", "VECTOR_SET", "STRING_REF", "STRING_SET", - "MAKE_PROCEDURE", "MAKE_VECTOR", "NULLP", "INTEGERP", - "SYMBOLP", "CHARP", "EOFP", "TYPEP", - "CAR", "CDR", "SET_CAR", "SET_CDR", "CONS", "ADD", "SUB", "MUL", "DIV", - "QUOT", "MOD", "NEG", "INV", "LT", "LE", "EQV", "EQ", "DISPLAY", "WRITE", - "WRITE_CHAR", "NEWLINE", "FLUSH_OUTPUT", "READ", "READ_CHAR", "RET", "DONE", + "MAKE_PROCEDURE", "MAKE_VECTOR", "NULLP", "INTEGERP", "SYMBOLP", "CHARP", + "EOFP", "TYPEP", "CAR", "CDR", "SET_CAR", "SET_CDR", "CONS", "ADD", "SUB", + "MUL", "DIV", "QUOT", "MOD", "NEG", "INV", "LT", "LE", "EQV", "EQ", + "DISPLAY", "WRITE", "WRITE_CHAR", "NEWLINE", "FLUSH_OUTPUT", "READ", + "READ_CHAR", "RET", "DONE", }; void disasm (sexp bc, sexp out) { diff --git a/eval.c b/eval.c index 4f636ddb..1e3a8654 100644 --- a/eval.c +++ b/eval.c @@ -88,7 +88,7 @@ static sexp env_global_ref(sexp e, sexp key, sexp dflt) { static void env_define(sexp e, sexp key, sexp value) { sexp cell = sexp_assq(key, sexp_env_bindings(e)); if (cell != SEXP_FALSE) - sexp_cdar(cell) = value; + sexp_cdr(cell) = value; else sexp_push(sexp_env_bindings(e), sexp_cons(key, value)); } @@ -278,6 +278,25 @@ static sexp sexp_identifierp (sexp x) { return sexp_make_boolean(sexp_idp(x)); } +static sexp sexp_identifier_eq (sexp e1, sexp id1, sexp e2, sexp id2) { + sexp cell, lam1=SEXP_FALSE, lam2=SEXP_FALSE; + if (sexp_synclop(id1)) { + e1 = sexp_synclo_env(id1); + id1 = sexp_synclo_expr(id1); + } + if (sexp_synclop(id2)) { + e2 = sexp_synclo_env(id2); + id2 = sexp_synclo_expr(id2); + } + cell = env_cell(e1, id1); + if (sexp_lambdap(sexp_cdr(cell))) + lam1 = sexp_cdr(cell); + cell = env_cell(e2, id2); + if (sexp_lambdap(sexp_cdr(cell))) + lam2 = sexp_cdr(cell); + return sexp_make_boolean((id1 == id2) && (lam1 == lam2)); +} + /************************* the compiler ***************************/ static sexp sexp_compile_error(char *message, sexp irritants) { @@ -298,10 +317,14 @@ static sexp analyze (sexp x, sexp context) { sexp op, cell, res; loop: if (sexp_pairp(x)) { - if (! sexp_listp(x)) { + if (sexp_listp(x) == SEXP_FALSE) { res = sexp_compile_error("dotted list in source", sexp_list1(x)); } else if (sexp_idp(sexp_car(x))) { - cell = env_cell(sexp_context_env(context), sexp_car(x)); + if (sexp_synclop(sexp_car(x))) + cell = env_cell(sexp_synclo_env(sexp_car(x)), + sexp_synclo_expr(sexp_car(x))); + else + cell = env_cell(sexp_context_env(context), sexp_car(x)); if (! cell) return analyze_app(x, context); op = sexp_cdr(cell); if (sexp_corep(op)) { @@ -365,7 +388,7 @@ static sexp analyze_lambda (sexp x, sexp context) { if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) return sexp_compile_error("bad lambda syntax", sexp_list1(x)); for (ls=sexp_cadr(x); sexp_pairp(ls); ls=sexp_cdr(ls)) - if (! sexp_symbolp(sexp_car(ls))) + if (! sexp_idp(sexp_car(ls))) return sexp_compile_error("non-symbol parameter", sexp_list1(x)); else if (sexp_memq(sexp_car(ls), sexp_cdr(ls)) != SEXP_FALSE) return sexp_compile_error("duplicate parameter", sexp_list1(x)); @@ -757,7 +780,8 @@ static void generate_lambda (sexp lambda, sexp context) { } } generate(sexp_lambda_body(lambda), ctx); - flags = sexp_make_integer(sexp_listp(sexp_lambda_params(lambda)) ? 0 : 1); + flags = sexp_make_integer((sexp_listp(sexp_lambda_params(lambda))==SEXP_FALSE) + ? 1 : 0); len = sexp_length(sexp_lambda_params(lambda)); bc = finalize_bytecode(ctx); if (sexp_nullp(fv)) { @@ -1404,91 +1428,9 @@ static struct sexp_struct core_forms[] = { {.tag=SEXP_CORE, .value={.core={CORE_LETREC_SYNTAX, "letrec-syntax"}}}, }; -static struct sexp_struct opcodes[] = { -#define _OP(c,o,n,m,t,u,i,s,d,p) {.tag=SEXP_OPCODE, .value={.opcode={c, o, n, m, t, u, i, s, d, p}}} -#define _FN(o,n,t,u,s,f) _OP(OPC_FOREIGN, o, n, 0, t, u, 0, s, (sexp)f, NULL) -#define _FN0(s, f) _FN(OP_FCALL0, 0, 0, 0, s, f) -#define _FN1(t, s, f) _FN(OP_FCALL1, 1, t, 0, s, f) -#define _FN2(t, u, s, f) _FN(OP_FCALL2, 2, t, u, s, f) -#define _FN3(t, u, s, f) _FN(OP_FCALL3, 3, t, u, s, f) -#define _PARAM(n,a,t) _OP(OPC_PARAMETER, OP_NOOP, 0, 2, t, 0, 0, n, a, NULL) -_OP(OPC_ACCESSOR, OP_CAR, 1, 0, SEXP_PAIR, 0, 0, "car", NULL, NULL), -_OP(OPC_ACCESSOR, OP_SET_CAR, 2, 0, SEXP_PAIR, 0, 0, "set-car!", NULL, NULL), -_OP(OPC_ACCESSOR, OP_CDR, 1, 0, SEXP_PAIR, 0, 0, "cdr", NULL, NULL), -_OP(OPC_ACCESSOR, OP_SET_CDR, 2, 0, SEXP_PAIR, 0, 0, "set-cdr!", NULL, NULL), -_OP(OPC_ACCESSOR, OP_VECTOR_REF,2,0, SEXP_VECTOR, SEXP_FIXNUM, 0,"vector-ref", NULL, NULL), -_OP(OPC_ACCESSOR, OP_VECTOR_SET,3,0, SEXP_VECTOR, SEXP_FIXNUM, 0,"vector-set!", NULL, NULL), -_OP(OPC_ACCESSOR, OP_STRING_REF,2,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-ref", NULL, NULL), -_OP(OPC_ACCESSOR, OP_STRING_SET,3,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-set!", NULL, NULL), -_OP(OPC_ARITHMETIC, OP_ADD, 0, 1, SEXP_FIXNUM, 0, 0, "+", NULL, NULL), -_OP(OPC_ARITHMETIC, OP_MUL, 0, 1, SEXP_FIXNUM, 0, 0, "*", NULL, NULL), -_OP(OPC_ARITHMETIC_INV, OP_SUB, 0, 1, SEXP_FIXNUM, 0, OP_NEG, "-", NULL, NULL), -_OP(OPC_ARITHMETIC_INV, OP_DIV, 0, 1, SEXP_FIXNUM, 0, OP_INV, "/", NULL, NULL), -_OP(OPC_ARITHMETIC, OP_QUOT, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, 0, "quotient", NULL, NULL), -_OP(OPC_ARITHMETIC, OP_MOD, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, 0, "modulo", NULL, NULL), -_OP(OPC_ARITHMETIC_CMP, OP_LT, 0, 1, SEXP_FIXNUM, 0, 0, "<", NULL, NULL), -_OP(OPC_ARITHMETIC_CMP, OP_LE, 0, 1, SEXP_FIXNUM, 0, 0, "<=", NULL, NULL), -_OP(OPC_ARITHMETIC_CMP, OP_LT, 0, 1, SEXP_FIXNUM, 0, 1, ">", NULL, NULL), -_OP(OPC_ARITHMETIC_CMP, OP_LE, 0, 1, SEXP_FIXNUM, 0, 1, ">=", NULL, NULL), -_OP(OPC_ARITHMETIC_CMP, OP_EQ, 0, 1, SEXP_FIXNUM, 0, 0, "=", NULL, NULL), -_OP(OPC_PREDICATE, OP_EQ, 2, 0, 0, 0, 0, "eq?", NULL, NULL), -_OP(OPC_CONSTRUCTOR, OP_CONS, 2, 0, 0, 0, 0, "cons", NULL, NULL), -_OP(OPC_CONSTRUCTOR, OP_MAKE_VECTOR, 2, 0, SEXP_FIXNUM, 0, 0, "make-vector", NULL, NULL), -_OP(OPC_CONSTRUCTOR, OP_MAKE_PROCEDURE, 4, 0, 0, 0, 0, "make-procedure", NULL, NULL), -_OP(OPC_TYPE_PREDICATE, OP_NULLP, 1, 0, 0, 0, 0, "null?", NULL, NULL), -_OP(OPC_TYPE_PREDICATE, OP_EOFP, 1, 0, 0, 0, 0, "eof-object?", NULL, NULL), -_OP(OPC_TYPE_PREDICATE, OP_SYMBOLP, 1, 0, 0, 0, 0, "symbol?", NULL, NULL), -_OP(OPC_TYPE_PREDICATE, OP_CHARP, 1, 0, 0, 0, 0, "char?", NULL, NULL), -_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "pair?", (sexp)SEXP_PAIR, NULL), -_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "string?", (sexp)SEXP_STRING, NULL), -_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "vector?", (sexp)SEXP_VECTOR, NULL), -_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "procedure?", (sexp)SEXP_PROCEDURE, NULL), -_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "input-port?", (sexp)SEXP_IPORT, NULL), -_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "output-port?", (sexp)SEXP_OPORT, NULL), -_OP(OPC_GENERIC, OP_APPLY1, 2, 0, SEXP_PROCEDURE, SEXP_PAIR, 0, "apply1", NULL, NULL), -_OP(OPC_GENERIC, OP_CALLCC, 1, SEXP_PROCEDURE, 0, 0, 0, "call-with-current-continuation", NULL, NULL), -_OP(OPC_GENERIC, OP_ERROR, 1, SEXP_STRING, 0, 0, 0, "error", NULL, NULL), -_OP(OPC_IO, OP_WRITE, 1, 3, 0, SEXP_OPORT, 0, "write", (sexp)"*current-output-port*", NULL), -_OP(OPC_IO, OP_DISPLAY, 1, 3, 0, SEXP_OPORT, 0, "display", (sexp)"*current-output-port*", NULL), -_OP(OPC_IO, OP_WRITE_CHAR, 1, 3, 0, SEXP_OPORT, 0, "write-char", (sexp)"*current-output-port*", NULL), -_OP(OPC_IO, OP_NEWLINE, 0, 3, 0, SEXP_OPORT, 0, "newline", (sexp)"*current-output-port*", NULL), -_OP(OPC_IO, OP_FLUSH_OUTPUT, 0, 3, 0, SEXP_OPORT, 0, "flush-output", (sexp)"*current-output-port*", NULL), -_OP(OPC_IO, OP_READ, 0, 3, 0, SEXP_IPORT, 0, "read", (sexp)"*current-input-port*", NULL), -_OP(OPC_IO, OP_READ_CHAR, 0, 3, 0, SEXP_IPORT, 0, "read-char", (sexp)"*current-input-port*", NULL), -_OP(OPC_GENERIC, OP_EVAL, 1, 3, 0, 0, 0, "eval", (sexp)"*interaction-environment*", NULL), -_FN1(0, "identifier?", sexp_identifierp), -_FN1(SEXP_PAIR, "length", sexp_length), -_FN1(SEXP_PAIR, "reverse", sexp_reverse), -_FN1(SEXP_PAIR, "list->vector", sexp_list_to_vector), -_FN1(SEXP_STRING, "open-input-file", sexp_open_input_file), -_FN1(SEXP_STRING, "open-output-file", sexp_open_output_file), -_FN1(SEXP_IPORT, "close-input-port", sexp_close_port), -_FN1(SEXP_OPORT, "close-output-port", sexp_close_port), -_FN1(SEXP_FIXNUM, "null-environment", sexp_make_null_env), -_FN1(SEXP_FIXNUM, "scheme-report-environment", sexp_make_standard_env), -_FN2(0, SEXP_ENV, "%load", sexp_load), -#if USE_MATH -_FN1(0, "exp", sexp_exp), -_FN1(0, "log", sexp_log), -_FN1(0, "sin", sexp_sin), -_FN1(0, "cos", sexp_cos), -_FN1(0, "tan", sexp_tan), -_FN1(0, "asin", sexp_asin), -_FN1(0, "acos", sexp_acos), -_FN1(0, "atan", sexp_atan), -_FN1(0, "sqrt", sexp_sqrt), -#endif -_FN2(0, SEXP_PAIR, "memq", sexp_memq), -_FN2(0, SEXP_PAIR, "assq", sexp_assq), -_FN3(SEXP_ENV, SEXP_PAIR, "make-syntactic-closure", sexp_make_synclo), -_PARAM("current-input-port", (sexp)"*current-input-port*", SEXP_IPORT), -_PARAM("current-output-port", (sexp)"*current-output-port*", SEXP_OPORT), -_PARAM("current-error-port", (sexp)"*current-error-port*", SEXP_OPORT), -_PARAM("current-error-handler", (sexp)"*current-error-handler*", SEXP_PROCEDURE), -_PARAM("interaction-environment", (sexp)"*interaction-environment*", SEXP_ENV), -}; +#include "opcodes.c" -static sexp standard_env_syms_interned_p = 0; +static int standard_env_syms_interned_p = 0; static sexp sexp_make_null_env (sexp version) { sexp_uint_t i; @@ -1502,16 +1444,17 @@ static sexp sexp_make_null_env (sexp version) { static sexp sexp_make_standard_env (sexp version) { sexp_uint_t i; - sexp e = sexp_make_null_env(version), cell, sym; + sexp e = sexp_make_null_env(version), op, cell, sym; for (i=0; i<(sizeof(opcodes)/sizeof(opcodes[0])); i++) { + op = &opcodes[i]; if ((! standard_env_syms_interned_p) - && sexp_opcode_opt_param_p(&opcodes[i]) - && sexp_opcode_data(&opcodes[i])) { - sym = sexp_intern((char*)sexp_opcode_data(&opcodes[i])); + && sexp_opcode_opt_param_p(op) + && sexp_opcode_data(op)) { + sym = sexp_intern((char*)sexp_opcode_data(op)); cell = env_cell_create(e, sym, SEXP_UNDEF); - sexp_opcode_data(&opcodes[i]) = cell; + sexp_opcode_data(op) = cell; } - env_define(e, sexp_intern(sexp_opcode_name(&opcodes[i])), &opcodes[i]); + env_define(e, sexp_intern(sexp_opcode_name(op)), op); } env_define(e, the_cur_in_symbol, sexp_make_input_port(stdin)); env_define(e, the_cur_out_symbol, sexp_make_output_port(stdout)); @@ -1523,7 +1466,6 @@ static sexp sexp_make_standard_env (sexp version) { /************************** eval interface ****************************/ -/* args ... n ret-ip ret-cp ret-fp */ sexp apply(sexp proc, sexp args, sexp context) { sexp *stack = sexp_context_stack(context), ls; sexp_sint_t top = sexp_context_top(context), offset; @@ -1558,9 +1500,9 @@ sexp compile (sexp x, sexp context) { sexp eval_in_context (sexp obj, sexp context) { sexp thunk = compile(obj, context); if (sexp_exceptionp(thunk)) { - sexp_print_exception(obj, env_global_ref(sexp_context_env(context), - the_cur_err_symbol, - SEXP_FALSE)); + sexp_print_exception(thunk, env_global_ref(sexp_context_env(context), + the_cur_err_symbol, + SEXP_FALSE)); return SEXP_UNDEF; } return apply(thunk, SEXP_NULL, context); diff --git a/eval.h b/eval.h index 1062ed9c..18a3d6dc 100644 --- a/eval.h +++ b/eval.h @@ -68,6 +68,7 @@ enum opcode_names { OP_FCALL1, OP_FCALL2, OP_FCALL3, + OP_FCALL4, OP_EVAL, OP_JUMP_UNLESS, OP_JUMP, diff --git a/init.scm b/init.scm index 1e6587de..b80658b1 100644 --- a/init.scm +++ b/init.scm @@ -1,22 +1,21 @@ -;; let* cond case delay and do +;; cond case delay do ;; quasiquote let-syntax -;; letrec-syntax syntax-rules eqv? equal? not boolean? number? +;; letrec-syntax syntax-rules not boolean? number? ;; complex? real? rational? integer? exact? inexact? ;; positive? negative? odd? even? max min quotient remainder ;; modulo numerator denominator floor ceiling truncate round -;; rationalize sqrt expt +;; rationalize expt ;; make-rectangular make-polar real-part imag-part magnitude angle ;; exact->inexact inexact->exact number->string string->number -;; list? list-tail list-ref memv -;; member assv assoc symbol->string string->symbol +;; symbol->string string->symbol ;; char-alphabetic? char-numeric? char-whitespace? ;; char-upper-case? char-lower-case? char->integer integer->char ;; char-upcase char-downcase make-string string string-length ;; string=? string-ci=? string? ;; string<=? string>=? string-ci? string-ci<=? string-ci>=? ;; substring string-append string->list list->string string-copy -;; string-fill! make-vector vector vector-length +;; string-fill! vector vector-length ;; vector->list list->vector vector-fill! procedure? apply ;; map for-each force call-with-current-continuation values ;; call-with-values dynamic-wind scheme-report-environment @@ -24,8 +23,7 @@ ;; current-input-port current-output-port ;; with-input-from-file with-output-to-file open-input-file ;; open-output-file close-input-port close-output-port -;; peek-char eof-object? char-ready? -;; eval +;; peek-char char-ready? ;; provide c[ad]{2,4}r @@ -34,14 +32,14 @@ (define (cdar x) (cdr (car x))) (define (cddr x) (cdr (cdr x))) -;; (define (caaar x) (car (car (car x)))) -;; (define (caadr x) (car (car (cdr x)))) -;; (define (cadar x) (car (cdr (car x)))) -;; (define (caddr x) (car (cdr (cdr x)))) -;; (define (cdaar x) (cdr (car (car x)))) -;; (define (cdadr x) (cdr (car (cdr x)))) -;; (define (cddar x) (cdr (cdr (car x)))) -;; (define (cdddr x) (cdr (cdr (cdr x)))) +(define (caaar x) (car (car (car x)))) +(define (caadr x) (car (car (cdr x)))) +(define (cadar x) (car (cdr (car x)))) +(define (caddr x) (car (cdr (cdr x)))) +(define (cdaar x) (cdr (car (car x)))) +(define (cdadr x) (cdr (car (cdr x)))) +(define (cddar x) (cdr (cdr (car x)))) +(define (cdddr x) (cdr (cdr (cdr x)))) ;; (define (caaaar x) (car (car (car (car x))))) ;; (define (caaadr x) (car (car (car (cdr x))))) @@ -62,6 +60,33 @@ (define (list . args) args) +(define (list-tail ls k) + (if (zero? k) + ls + (list-tail (cdr ls) (- k 1)))) + +(define (list-ref ls k) (car (list-tail ls k))) + +(define eqv? equal?) + +(define (member obj ls) + (if (null? ls) + #f + (if (equal? obj (car ls)) + ls + (member obj (cdr ls))))) + +(define memv member) + +(define (assoc obj ls) + (if (null? ls) + #f + (if (equal? obj (caar ls)) + ls + (member obj (cdr ls))))) + +(define assv assoc) + (define (append-reverse a b) (if (pair? a) (append-reverse (cdr a) (cons (car a) b)) @@ -114,30 +139,74 @@ (lambda (expr use-env mac-env) (make-syntactic-closure use-env '() (f expr mac-env))))) -(define-syntax let - (lambda (expr use-env mac-env) - (cons (cons 'lambda (cons (map car (cadr expr)) (cddr expr))) - (map cadr (cadr expr))))) +(define er-macro-transformer + (lambda (f) + (lambda (expr use-env mac-env) + ((lambda (rename compare) (f expr rename compare)) + ((lambda (renames) + (lambda (identifier) + ((lambda (cell) + (if cell + (cdr cell) + ((lambda (name) + (set! renames (cons (cons identifier name) renames)) + name) + (make-syntactic-closure mac-env '() identifier)))) + (assq identifier renames)))) + '()) + (lambda (x y) (identifier=? use-env x use-env y)))))) (define-syntax letrec - (lambda (expr use-env mac-env) - (list - (cons 'lambda - (cons '() - (append (map (lambda (x) (cons 'define x)) (cadr expr)) - (cddr expr))))))) + (er-macro-transformer + (lambda (expr rename compare) + (list + (cons (rename 'lambda) + (cons '() + (append (map (lambda (x) (cons (rename 'define) x)) (cadr expr)) + (cddr expr)))))))) + +(define-syntax let + (er-macro-transformer + (lambda (expr rename compare) + (if (identifier? (cadr expr)) + (list (rename 'letrec) + (list (list (cadr expr) + (cons (rename 'lambda) + (cons (map car (caddr expr)) + (cdddr expr))))) + (cons (cadr expr) (map cadr (caddr expr)))) + (cons (cons (rename 'lambda) (cons (map car (cadr expr)) (cddr expr))) + (map cadr (cadr expr))))))) + +(define-syntax let* + (er-macro-transformer + (lambda (expr rename compare) + (if (null? (cadr expr)) + (cons (rename 'begin) (cddr expr)) + (list (rename 'let) + (list (caadr expr)) + (cons (rename 'let*) (cons (cdadr expr) (cddr expr)))))))) (define-syntax or - (sc-macro-transformer - (lambda (expr use-env) + (er-macro-transformer + (lambda (expr rename compare) (if (null? (cdr expr)) #f + (list (rename 'let) (list (list (rename 'tmp) (cadr expr))) + (list (rename 'if) (rename 'tmp) + (rename 'tmp) + (cons (rename 'or) (cddr expr)))))))) + +(define-syntax and + (er-macro-transformer + (lambda (expr rename compare) + (if (null? (cdr expr)) + #t (if (null? (cddr expr)) - (make-syntactic-closure use-env '() (cadr expr)) - (list 'let (list (list 'tmp (make-syntactic-closure use-env '() (cadr expr)))) - (list 'if 'tmp - 'tmp - (make-syntactic-closure use-env '() (cons 'or (cddr expr)))))))))) + (cadr expr) + (list (rename 'if) (cadr expr) + (cons (rename 'and) (cddr expr)) + #f)))))) ;; char utils diff --git a/opcodes.c b/opcodes.c new file mode 100644 index 00000000..faac6fb3 --- /dev/null +++ b/opcodes.c @@ -0,0 +1,90 @@ + +#define _OP(c,o,n,m,t,u,i,s,d,p) {.tag=SEXP_OPCODE, .value={.opcode={c, o, n, m, t, u, i, s, d, p}}} +#define _FN(o,n,t,u,s,f) _OP(OPC_FOREIGN, o, n, 0, t, u, 0, s, (sexp)f, NULL) +#define _FN0(s, f) _FN(OP_FCALL0, 0, 0, 0, s, f) +#define _FN1(t, s, f) _FN(OP_FCALL1, 1, t, 0, s, f) +#define _FN2(t, u, s, f) _FN(OP_FCALL2, 2, t, u, s, f) +#define _FN3(t, u, s, f) _FN(OP_FCALL3, 3, t, u, s, f) +#define _FN4(t, u, s, f) _FN(OP_FCALL4, 4, t, u, s, f) +#define _PARAM(n,a,t) _OP(OPC_PARAMETER, OP_NOOP, 0, 2, t, 0, 0, n, a, NULL) + +static struct sexp_struct opcodes[] = { +_OP(OPC_ACCESSOR, OP_CAR, 1, 0, SEXP_PAIR, 0, 0, "car", NULL, NULL), +_OP(OPC_ACCESSOR, OP_SET_CAR, 2, 0, SEXP_PAIR, 0, 0, "set-car!", NULL, NULL), +_OP(OPC_ACCESSOR, OP_CDR, 1, 0, SEXP_PAIR, 0, 0, "cdr", NULL, NULL), +_OP(OPC_ACCESSOR, OP_SET_CDR, 2, 0, SEXP_PAIR, 0, 0, "set-cdr!", NULL, NULL), +_OP(OPC_ACCESSOR, OP_VECTOR_REF,2,0, SEXP_VECTOR, SEXP_FIXNUM, 0,"vector-ref", NULL, NULL), +_OP(OPC_ACCESSOR, OP_VECTOR_SET,3,0, SEXP_VECTOR, SEXP_FIXNUM, 0,"vector-set!", NULL, NULL), +_OP(OPC_ACCESSOR, OP_STRING_REF,2,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-ref", NULL, NULL), +_OP(OPC_ACCESSOR, OP_STRING_SET,3,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-set!", NULL, NULL), +_OP(OPC_ARITHMETIC, OP_ADD, 0, 1, SEXP_FIXNUM, 0, 0, "+", NULL, NULL), +_OP(OPC_ARITHMETIC, OP_MUL, 0, 1, SEXP_FIXNUM, 0, 0, "*", NULL, NULL), +_OP(OPC_ARITHMETIC_INV, OP_SUB, 0, 1, SEXP_FIXNUM, 0, OP_NEG, "-", NULL, NULL), +_OP(OPC_ARITHMETIC_INV, OP_DIV, 0, 1, SEXP_FIXNUM, 0, OP_INV, "/", NULL, NULL), +_OP(OPC_ARITHMETIC, OP_QUOT, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, 0, "quotient", NULL, NULL), +_OP(OPC_ARITHMETIC, OP_MOD, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, 0, "modulo", NULL, NULL), +_OP(OPC_ARITHMETIC_CMP, OP_LT, 0, 1, SEXP_FIXNUM, 0, 0, "<", NULL, NULL), +_OP(OPC_ARITHMETIC_CMP, OP_LE, 0, 1, SEXP_FIXNUM, 0, 0, "<=", NULL, NULL), +_OP(OPC_ARITHMETIC_CMP, OP_LT, 0, 1, SEXP_FIXNUM, 0, 1, ">", NULL, NULL), +_OP(OPC_ARITHMETIC_CMP, OP_LE, 0, 1, SEXP_FIXNUM, 0, 1, ">=", NULL, NULL), +_OP(OPC_ARITHMETIC_CMP, OP_EQ, 0, 1, SEXP_FIXNUM, 0, 0, "=", NULL, NULL), +_OP(OPC_PREDICATE, OP_EQ, 2, 0, 0, 0, 0, "eq?", NULL, NULL), +_OP(OPC_CONSTRUCTOR, OP_CONS, 2, 0, 0, 0, 0, "cons", NULL, NULL), +_OP(OPC_CONSTRUCTOR, OP_MAKE_VECTOR, 2, 0, SEXP_FIXNUM, 0, 0, "make-vector", NULL, NULL), +_OP(OPC_CONSTRUCTOR, OP_MAKE_PROCEDURE, 4, 0, 0, 0, 0, "make-procedure", NULL, NULL), +_OP(OPC_TYPE_PREDICATE, OP_NULLP, 1, 0, 0, 0, 0, "null?", NULL, NULL), +_OP(OPC_TYPE_PREDICATE, OP_EOFP, 1, 0, 0, 0, 0, "eof-object?", NULL, NULL), +_OP(OPC_TYPE_PREDICATE, OP_SYMBOLP, 1, 0, 0, 0, 0, "symbol?", NULL, NULL), +_OP(OPC_TYPE_PREDICATE, OP_CHARP, 1, 0, 0, 0, 0, "char?", NULL, NULL), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "pair?", (sexp)SEXP_PAIR, NULL), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "string?", (sexp)SEXP_STRING, NULL), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "vector?", (sexp)SEXP_VECTOR, NULL), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "procedure?", (sexp)SEXP_PROCEDURE, NULL), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "input-port?", (sexp)SEXP_IPORT, NULL), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "output-port?", (sexp)SEXP_OPORT, NULL), +_OP(OPC_GENERIC, OP_APPLY1, 2, 0, SEXP_PROCEDURE, SEXP_PAIR, 0, "apply1", NULL, NULL), +_OP(OPC_GENERIC, OP_CALLCC, 1, SEXP_PROCEDURE, 0, 0, 0, "call-with-current-continuation", NULL, NULL), +_OP(OPC_GENERIC, OP_ERROR, 1, SEXP_STRING, 0, 0, 0, "error", NULL, NULL), +_OP(OPC_IO, OP_WRITE, 1, 3, 0, SEXP_OPORT, 0, "write", (sexp)"*current-output-port*", NULL), +_OP(OPC_IO, OP_DISPLAY, 1, 3, 0, SEXP_OPORT, 0, "display", (sexp)"*current-output-port*", NULL), +_OP(OPC_IO, OP_WRITE_CHAR, 1, 3, 0, SEXP_OPORT, 0, "write-char", (sexp)"*current-output-port*", NULL), +_OP(OPC_IO, OP_NEWLINE, 0, 3, 0, SEXP_OPORT, 0, "newline", (sexp)"*current-output-port*", NULL), +_OP(OPC_IO, OP_FLUSH_OUTPUT, 0, 3, 0, SEXP_OPORT, 0, "flush-output", (sexp)"*current-output-port*", NULL), +_OP(OPC_IO, OP_READ, 0, 3, 0, SEXP_IPORT, 0, "read", (sexp)"*current-input-port*", NULL), +_OP(OPC_IO, OP_READ_CHAR, 0, 3, 0, SEXP_IPORT, 0, "read-char", (sexp)"*current-input-port*", NULL), +_OP(OPC_GENERIC, OP_EVAL, 1, 3, 0, 0, 0, "eval", (sexp)"*interaction-environment*", NULL), +_FN2(0, 0, "equal?", sexp_equalp), +_FN1(0, "list?", sexp_listp), +_FN1(0, "identifier?", sexp_identifierp), +_FN4(0, SEXP_ENV, "identifier=?", sexp_identifier_eq), +_FN1(SEXP_PAIR, "length", sexp_length), +_FN1(SEXP_PAIR, "reverse", sexp_reverse), +_FN1(SEXP_PAIR, "list->vector", sexp_list_to_vector), +_FN1(SEXP_STRING, "open-input-file", sexp_open_input_file), +_FN1(SEXP_STRING, "open-output-file", sexp_open_output_file), +_FN1(SEXP_IPORT, "close-input-port", sexp_close_port), +_FN1(SEXP_OPORT, "close-output-port", sexp_close_port), +_FN1(SEXP_FIXNUM, "null-environment", sexp_make_null_env), +_FN1(SEXP_FIXNUM, "scheme-report-environment", sexp_make_standard_env), +_FN2(0, SEXP_ENV, "%load", sexp_load), +#if USE_MATH +_FN1(0, "exp", sexp_exp), +_FN1(0, "log", sexp_log), +_FN1(0, "sin", sexp_sin), +_FN1(0, "cos", sexp_cos), +_FN1(0, "tan", sexp_tan), +_FN1(0, "asin", sexp_asin), +_FN1(0, "acos", sexp_acos), +_FN1(0, "atan", sexp_atan), +_FN1(0, "sqrt", sexp_sqrt), +#endif +_FN2(0, SEXP_PAIR, "memq", sexp_memq), +_FN2(0, SEXP_PAIR, "assq", sexp_assq), +_FN3(SEXP_ENV, SEXP_PAIR, "make-syntactic-closure", sexp_make_synclo), +_PARAM("current-input-port", (sexp)"*current-input-port*", SEXP_IPORT), +_PARAM("current-output-port", (sexp)"*current-output-port*", SEXP_OPORT), +_PARAM("current-error-port", (sexp)"*current-error-port*", SEXP_OPORT), +_PARAM("current-error-handler", (sexp)"*current-error-handler*", SEXP_PROCEDURE), +_PARAM("interaction-environment", (sexp)"*interaction-environment*", SEXP_ENV), +}; + diff --git a/sexp.c b/sexp.c index 5c5efb76..65118d45 100644 --- a/sexp.c +++ b/sexp.c @@ -91,8 +91,8 @@ void sexp_deep_free (sexp obj) { /***************************** exceptions *****************************/ -sexp sexp_make_exception(sexp kind, sexp message, sexp irritants, - sexp file, sexp line) { +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; @@ -102,11 +102,11 @@ sexp sexp_make_exception(sexp kind, sexp message, sexp irritants, return exn; } -sexp sexp_print_exception(sexp exn, sexp out) { +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_exception_line(exn) > sexp_make_integer(0))) { sexp_write_string(" on line ", out); sexp_write(sexp_exception_line(exn), out); } @@ -116,7 +116,8 @@ sexp sexp_print_exception(sexp exn, sexp 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_exception_irritants(exn) + && 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); @@ -136,7 +137,7 @@ sexp sexp_print_exception(sexp exn, sexp out) { return SEXP_UNDEF; } -static sexp sexp_read_error(char *message, sexp irritants, sexp port) { +static sexp sexp_read_error (char *message, sexp irritants, sexp port) { sexp name = (sexp_port_name(port) ? sexp_make_string(sexp_port_name(port)) : SEXP_FALSE); return sexp_make_exception(the_read_error_symbol, @@ -148,17 +149,17 @@ static sexp sexp_read_error(char *message, sexp irritants, sexp port) { /*************************** list utilities ***************************/ -sexp sexp_cons(sexp head, sexp tail) { +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) { +sexp sexp_listp (sexp obj) { while (sexp_pairp(obj)) obj = sexp_cdr(obj); - return (obj == SEXP_NULL); + return sexp_make_boolean(obj == SEXP_NULL); } sexp sexp_memq (sexp x, sexp ls) { @@ -172,21 +173,21 @@ sexp sexp_memq (sexp x, sexp ls) { sexp sexp_assq (sexp x, sexp ls) { while (sexp_pairp(ls)) - if (x == sexp_caar(ls)) - return ls; + if (sexp_pairp(sexp_car(ls)) && (x == sexp_caar(ls))) + return sexp_car(ls); else ls = sexp_cdr(ls); return SEXP_FALSE; } -sexp sexp_reverse(sexp ls) { +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 sexp_nreverse (sexp ls) { sexp a, b, tmp; if (ls == SEXP_NULL) { return ls; @@ -204,19 +205,62 @@ sexp sexp_nreverse(sexp ls) { } } -sexp sexp_append(sexp a, sexp 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 sexp_length (sexp ls) { sexp_uint_t res=0; for ( ; sexp_pairp(ls); res++, ls=sexp_cdr(ls)) ; return sexp_make_integer(res); } +sexp sexp_equalp (sexp a, sexp b) { + sexp_uint_t len; + sexp *v1, *v2; + loop: + if (a == b) + return SEXP_TRUE; + if (! sexp_pointerp(a)) + return sexp_make_boolean(sexp_integerp(a) && sexp_pointerp(b) + && (sexp_unbox_integer(a) + == sexp_flonum_value(b))); + else if (! sexp_pointerp(b)) + return sexp_make_boolean(sexp_integerp(b) && sexp_pointerp(a) + && (sexp_unbox_integer(b) + == sexp_flonum_value(a))); + if (sexp_pointer_tag(a) != sexp_pointer_tag(b)) + return SEXP_FALSE; + switch (sexp_pointer_tag(a)) { + case SEXP_PAIR: + if (sexp_equalp(sexp_car(a), sexp_car(b)) == SEXP_FALSE) + return SEXP_FALSE; + a = sexp_cdr(a); + b = sexp_cdr(b); + goto loop; + case SEXP_VECTOR: + len = sexp_vector_length(a); + if (len != sexp_vector_length(b)) + return SEXP_FALSE; + v1 = sexp_vector_data(a); + v2 = sexp_vector_data(b); + for (len--; len >= 0; len--) + if (sexp_equalp(v1[len], v2[len]) == SEXP_FALSE) + return SEXP_FALSE; + return SEXP_TRUE; + case SEXP_STRING: + return sexp_make_boolean((sexp_string_length(a) == sexp_string_length(b)) + && (! strncmp(sexp_string_data(a), + sexp_string_data(b), + sexp_string_length(a)))); + default: + return SEXP_FALSE; + } +} + /********************* strings, symbols, vectors **********************/ sexp sexp_make_flonum(double f) { @@ -805,7 +849,7 @@ sexp sexp_read_raw (sexp in) { case '(': sexp_push_char(c1, in); res = sexp_read(in); - if (! sexp_listp(res)) { + if (sexp_listp(res) == SEXP_FALSE) { if (! sexp_exceptionp(res)) { sexp_deep_free(res); res = sexp_read_error("dotted list not allowed in vector syntax", diff --git a/sexp.h b/sexp.h index 81f26e7d..a8f13150 100644 --- a/sexp.h +++ b/sexp.h @@ -153,7 +153,7 @@ struct sexp_struct { } lit; /* compiler state */ struct { - sexp bc, lambda, offsets, *stack, env; + sexp bc, lambda, *stack, env; sexp_uint_t pos, top, depth, tailp; } context; } value; @@ -326,7 +326,6 @@ struct sexp_struct { #define sexp_context_pos(x) ((x)->value.context.pos) #define sexp_context_top(x) ((x)->value.context.top) #define sexp_context_lambda(x) ((x)->value.context.lambda) -#define sexp_context_offsets(x) ((x)->value.context.offsets) #define sexp_context_tailp(x) ((x)->value.context.tailp) /****************************** arithmetic ****************************/ @@ -400,7 +399,8 @@ void sexp_printf(sexp port, sexp fmt, ...); sexp sexp_alloc_tagged(size_t size, sexp_uint_t tag); sexp sexp_cons(sexp head, sexp tail); -int sexp_listp(sexp obj); +sexp sexp_equalp (sexp a, sexp b); +sexp sexp_listp(sexp obj); sexp sexp_reverse(sexp ls); sexp sexp_nreverse(sexp ls); sexp sexp_append(sexp a, sexp b); From 51352245b2a7e5ae1cba1121457a0eaf49d9fe27 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Wed, 1 Apr 2009 13:02:49 +0900 Subject: [PATCH 075/154] adding more macros --- eval.c | 1 + eval.h | 2 +- init.scm | 68 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 70 insertions(+), 1 deletion(-) diff --git a/eval.c b/eval.c index 1e3a8654..62dfaa2f 100644 --- a/eval.c +++ b/eval.c @@ -358,6 +358,7 @@ static sexp analyze (sexp x, sexp context) { x = apply(sexp_macro_proc(op), sexp_list3(x, sexp_context_env(context), sexp_macro_env(op)), context); + /* sexp_debug("expand => ", x, context); */ goto loop; } else if (sexp_opcodep(op)) { res = analyze_app(sexp_cdr(x), context); diff --git a/eval.h b/eval.h index 18a3d6dc..bf1e5375 100644 --- a/eval.h +++ b/eval.h @@ -18,7 +18,7 @@ #define sexp_init_file "init.scm" -#define sexp_debug(msg, obj) (sexp_write_string(msg,cur_error_port), sexp_write(obj, cur_error_port), sexp_write_char('\n',cur_error_port)) +#define sexp_debug(msg, obj, ctx) (sexp_write_string(msg,env_global_ref(sexp_context_env(ctx), the_cur_err_symbol, SEXP_FALSE)), sexp_write(obj, env_global_ref(sexp_context_env(ctx), the_cur_err_symbol, SEXP_FALSE)), sexp_write_char('\n',env_global_ref(sexp_context_env(ctx), the_cur_err_symbol, SEXP_FALSE))) /* procedure types */ typedef sexp (*sexp_proc0) (); diff --git a/init.scm b/init.scm index b80658b1..e3210566 100644 --- a/init.scm +++ b/init.scm @@ -208,6 +208,57 @@ (cons (rename 'and) (cddr expr)) #f)))))) +(define-syntax cond + (er-macro-transformer + (lambda (expr rename compare) + (if (null? (cdr expr)) + #f + (let ((cl (cadr expr))) + (if (eq? 'else (car cl)) + (cons (rename 'begin) (cdr cl)) + (if (if (null? (cdr cl)) #t (eq? '=> (cadr cl))) + (list (rename 'let) + (list (list (rename 'tmp) (car cl))) + (list (rename 'if) (rename 'tmp) + (if (null? (cdr cl)) + (rename 'tmp) + (list (caddr cl) (rename 'tmp))))) + (list (rename 'if) + (car cl) + (cons (rename 'begin) (cdr cl)) + (cons (rename 'cond) (cddr expr)))))))))) + +(define-syntax quasiquote + (er-macro-transformer + (lambda (expr rename compare) + (define (qq x d) + (if (pair? x) + (if (eq? 'unquote (car x)) + (if (<= d 0) + (cadr x) + (list (rename 'unquote) (qq (cadr x) (- d 1)))) + (if (eq? 'unquote-splicing (car x)) + (if (<= d 0) + (list (rename 'cons) (qq (car x) d) (qq (cdr x) d)) + (list (rename 'unquote-splicing) (qq (cadr x) (- d 1)))) + (if (eq? 'quasiquote (car x)) + (list (rename 'quasiquote) (qq (cadr x) (+ d 1))) + (if (and (<= d 0) + (pair? (car x)) + (eq? 'unquote-splicing (caar x))) + (list (rename 'append) + (cadar x) + (qq (cdr x) d)) + (list (rename 'cons) + (qq (car x) d) + (qq (cdr x) d)))))) + (if (vector? x) + (list (rename 'list->vector) (qq (vector->list x) d)) + (if (symbol? x) + (list (rename 'quote) x) + x)))) + (qq (cadr expr) 0)))) + ;; char utils ;; (define (char=? a b) (= (char->integer a) (char->integer b))) @@ -227,6 +278,23 @@ ;; (define (char-ci>=? a b) ;; (>= (char->integer (char-downcase a)) (char->integer (char-downcase b)))) +;; vector utils + +(define (list->vector ls) + (let ((vec (make-vector (length ls)))) + (let lp ((ls ls) (i 0)) + (if (pair? ls) + (begin + (vector-set! vec i (car ls)) + (lp (cdr ls) (+ i 1))))) + vec)) + +(define (vector->list vec) + (let lp ((i (- (vector-length vec) 1)) (res '())) + (if (< i 0) + res + (lp (- i 1) (cons (vector-ref vec i) res))))) + ;; math ;; (define (abs x) (if (< x 0) (- x) x)) From ee5f33c9fb896cafe804d504341b6e2b44bdb11d Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Wed, 1 Apr 2009 17:25:47 +0900 Subject: [PATCH 076/154] flushing out library --- debug.c | 7 +- eval.c | 74 ++++++++++--- eval.h | 4 + init.scm | 311 +++++++++++++++++++++++++++++++++--------------------- opcodes.c | 8 ++ sexp.c | 4 +- sexp.h | 2 + 7 files changed, 274 insertions(+), 136 deletions(-) diff --git a/debug.c b/debug.c index 052d2412..90d5c8db 100644 --- a/debug.c +++ b/debug.c @@ -6,12 +6,13 @@ static const char* reverse_opcode_names[] = {"NOOP", "ERROR", "RESUMECC", "CALLCC", "APPLY1", "TAIL_CALL", "CALL", "FCALL0", "FCALL1", "FCALL2", "FCALL3", "FCALL4", "EVAL", "JUMP_UNLESS", "JUMP", "PUSH", "DROP", "STACK_REF", "LOCAL_REF", "LOCAL_SET", - "CLOSURE_REF", "VECTOR_REF", "VECTOR_SET", "STRING_REF", "STRING_SET", + "CLOSURE_REF", "VECTOR_REF", "VECTOR_SET", "VECTOR_LENGTH", + "STRING_REF", "STRING_SET", "STRING_LENGTH", "MAKE_PROCEDURE", "MAKE_VECTOR", "NULLP", "INTEGERP", "SYMBOLP", "CHARP", "EOFP", "TYPEP", "CAR", "CDR", "SET_CAR", "SET_CDR", "CONS", "ADD", "SUB", "MUL", "DIV", "QUOT", "MOD", "NEG", "INV", "LT", "LE", "EQV", "EQ", - "DISPLAY", "WRITE", "WRITE_CHAR", "NEWLINE", "FLUSH_OUTPUT", "READ", - "READ_CHAR", "RET", "DONE", + "CHAR->INTEGER", "INTEGER->CHAR", "DISPLAY", "WRITE", "WRITE_CHAR", + "NEWLINE", "FLUSH_OUTPUT", "READ", "READ_CHAR", "RET", "DONE", }; void disasm (sexp bc, sexp out) { diff --git a/eval.c b/eval.c index 62dfaa2f..d6b4c8e8 100644 --- a/eval.c +++ b/eval.c @@ -135,6 +135,8 @@ static void shrink_bcode(sexp context, sexp_uint_t i) { if (sexp_bytecode_length(sexp_context_bc(context)) != i) { tmp = sexp_alloc_tagged(sexp_sizeof(bytecode) + i, SEXP_BYTECODE); sexp_bytecode_length(tmp) = i; + sexp_bytecode_literals(tmp) + = sexp_bytecode_literals(sexp_context_bc(context)); memcpy(sexp_bytecode_data(tmp), sexp_bytecode_data(sexp_context_bc(context)), i); @@ -151,6 +153,8 @@ static void expand_bcode(sexp context, sexp_uint_t size) { SEXP_BYTECODE); sexp_bytecode_length(tmp) = sexp_bytecode_length(sexp_context_bc(context))*2; + sexp_bytecode_literals(tmp) + = sexp_bytecode_literals(sexp_context_bc(context)); memcpy(sexp_bytecode_data(tmp), sexp_bytecode_data(sexp_context_bc(context)), sexp_bytecode_length(sexp_context_bc(context))); @@ -174,6 +178,8 @@ static void emit_word(sexp_uint_t val, sexp context) { static void emit_push(sexp obj, sexp context) { emit(OP_PUSH, context); emit_word((sexp_uint_t)obj, context); + if (sexp_pointerp(obj)) + sexp_push(sexp_bytecode_literals(sexp_context_bc(context)), obj); } static sexp sexp_make_procedure(sexp flags, sexp num_args, @@ -253,6 +259,7 @@ static sexp sexp_make_context(sexp *stack, sexp env) { sexp_context_bc(res) = sexp_alloc_tagged(sexp_sizeof(bytecode)+INIT_BCODE_SIZE, SEXP_BYTECODE); sexp_bytecode_length(sexp_context_bc(res)) = INIT_BCODE_SIZE; + sexp_bytecode_literals(sexp_context_bc(res)) = SEXP_NULL; sexp_context_lambda(res) = SEXP_FALSE; sexp_context_stack(res) = stack; sexp_context_env(res) = env; @@ -289,10 +296,10 @@ static sexp sexp_identifier_eq (sexp e1, sexp id1, sexp e2, sexp id2) { id2 = sexp_synclo_expr(id2); } cell = env_cell(e1, id1); - if (sexp_lambdap(sexp_cdr(cell))) + if (cell && sexp_lambdap(sexp_cdr(cell))) lam1 = sexp_cdr(cell); cell = env_cell(e2, id2); - if (sexp_lambdap(sexp_cdr(cell))) + if (cell && sexp_lambdap(sexp_cdr(cell))) lam2 = sexp_cdr(cell); return sexp_make_boolean((id1 == id2) && (lam1 == lam2)); } @@ -357,13 +364,21 @@ static sexp analyze (sexp x, sexp context) { } else if (sexp_macrop(op)) { x = apply(sexp_macro_proc(op), sexp_list3(x, sexp_context_env(context), sexp_macro_env(op)), - context); + sexp_child_context(context, sexp_context_lambda(context))); /* sexp_debug("expand => ", x, context); */ goto loop; } else if (sexp_opcodep(op)) { - res = analyze_app(sexp_cdr(x), context); - analyze_check_exception(res); - sexp_push(res, op); + res = sexp_length(sexp_cdr(x)); + if (sexp_unbox_integer(res) < sexp_opcode_num_args(op)) { + res = sexp_compile_error("not enough args for opcode", sexp_list1(x)); + } else if ((sexp_unbox_integer(res) > sexp_opcode_num_args(op)) + && (! sexp_opcode_variadic_p(op))) { + res = sexp_compile_error("too many args for opcode", sexp_list1(x)); + } else { + res = analyze_app(sexp_cdr(x), context); + analyze_check_exception(res); + sexp_push(res, op); + } } else { res = analyze_app(x, context); } @@ -537,10 +552,10 @@ static void sexp_context_patch_label (sexp context, sexp_sint_t label) { static sexp finalize_bytecode (sexp context) { emit(OP_RET, context); shrink_bcode(context, sexp_context_pos(context)); - disasm(sexp_context_bc(context), - env_global_ref(sexp_context_env(context), - the_cur_err_symbol, - SEXP_FALSE)); +/* disasm(sexp_context_bc(context), */ +/* env_global_ref(sexp_context_env(context), */ +/* the_cur_err_symbol, */ +/* SEXP_FALSE)); */ return sexp_context_bc(context); } @@ -950,8 +965,8 @@ sexp vm(sexp bc, sexp cp, sexp context, sexp* stack, sexp_sint_t top) { sexp_sint_t i, j, k, fp=top-4; loop: - /* print_stack(stack, top, fp); */ - /* fprintf(stderr, "%s\n", (*ip<=71)?reverse_opcode_names[*ip]:"UNKNOWN"); */ +/* print_stack(stack, top, fp, env_global_ref(env, the_cur_err_symbol, SEXP_FALSE)); */ +/* fprintf(stderr, "%s\n", (*ip<=71)?reverse_opcode_names[*ip]:"UNKNOWN"); */ switch (*ip++) { case OP_NOOP: fprintf(stderr, "<<>>\n"); @@ -1089,6 +1104,12 @@ sexp vm(sexp bc, sexp cp, sexp context, sexp* stack, sexp_sint_t top) { ip += sizeof(sexp); sexp_check_exception(); break; + case OP_FCALL4: + _ARG4 =((sexp_proc4)_UWORD0)(_ARG1, _ARG2, _ARG3, _ARG4); + top -= 3; + ip += sizeof(sexp); + sexp_check_exception(); + break; case OP_EVAL: sexp_context_top(context) = top; _ARG1 = eval_in_context(_ARG1, context); @@ -1142,6 +1163,9 @@ sexp vm(sexp bc, sexp cp, sexp context, sexp* stack, sexp_sint_t top) { _ARG3 = SEXP_UNDEF; top-=2; break; + case OP_VECTOR_LENGTH: + _ARG1 = sexp_make_integer(sexp_vector_length(_ARG1)); + break; case OP_STRING_REF: _ARG2 = sexp_string_ref(_ARG1, _ARG2); top--; @@ -1151,6 +1175,9 @@ sexp vm(sexp bc, sexp cp, sexp context, sexp* stack, sexp_sint_t top) { _ARG3 = SEXP_UNDEF; top-=2; break; + case OP_STRING_LENGTH: + _ARG1 = sexp_make_integer(sexp_string_length(_ARG1)); + break; case OP_MAKE_PROCEDURE: _ARG4 = sexp_make_procedure(_ARG1, _ARG2, _ARG3, _ARG4); top-=3; @@ -1289,11 +1316,13 @@ sexp vm(sexp bc, sexp cp, sexp context, sexp* stack, sexp_sint_t top) { else sexp_raise("/: not a number", sexp_list1(_ARG1)); break; case OP_LT: - _ARG2 = sexp_make_boolean(_ARG1 < _ARG2); + _ARG2 = sexp_make_boolean(sexp_unbox_integer(_ARG1) + < sexp_unbox_integer(_ARG2)); top--; break; case OP_LE: - _ARG2 = sexp_make_boolean(_ARG1 <= _ARG2); + _ARG2 = sexp_make_boolean(sexp_unbox_integer(_ARG1) + <= sexp_unbox_integer(_ARG2)); top--; break; case OP_EQ: @@ -1301,6 +1330,12 @@ sexp vm(sexp bc, sexp cp, sexp context, sexp* stack, sexp_sint_t top) { _ARG2 = sexp_make_boolean(_ARG1 == _ARG2); top--; break; + case OP_CHAR2INT: + _ARG1 = sexp_make_integer(sexp_unbox_character(_ARG1)); + break; + case OP_INT2CHAR: + _ARG1 = sexp_make_character(sexp_unbox_integer(_ARG1)); + break; case OP_DISPLAY: if (sexp_stringp(_ARG1)) { sexp_write_string(sexp_string_data(_ARG1), _ARG2); @@ -1412,6 +1447,10 @@ define_math_op(sexp_asin, asin) define_math_op(sexp_acos, acos) define_math_op(sexp_atan, atan) define_math_op(sexp_sqrt, sqrt) +define_math_op(sexp_round, round) +define_math_op(sexp_trunc, trunc) +define_math_op(sexp_floor, floor) +define_math_op(sexp_ceiling, ceil) #endif @@ -1526,6 +1565,13 @@ void scheme_init () { the_cur_out_symbol = sexp_intern("*current-output-port*"); the_cur_err_symbol = sexp_intern("*current-error-port*"); the_interaction_env_symbol = sexp_intern("*interaction-environment*"); +#if USE_BOEHM + GC_add_roots((char*)&continuation_resumer, + ((char*)&continuation_resumer)+sizeof(continuation_resumer)+1); + GC_add_roots((char*)&final_resumer, + ((char*)&final_resumer)+sizeof(continuation_resumer)+1); + GC_add_roots((char*)&opcodes, ((char*)&opcodes)+sizeof(opcodes)+1); +#endif context = sexp_make_context(NULL, NULL); emit(OP_RESUMECC, context); continuation_resumer = finalize_bytecode(context); diff --git a/eval.h b/eval.h index bf1e5375..4c42af99 100644 --- a/eval.h +++ b/eval.h @@ -80,8 +80,10 @@ enum opcode_names { OP_CLOSURE_REF, OP_VECTOR_REF, OP_VECTOR_SET, + OP_VECTOR_LENGTH, OP_STRING_REF, OP_STRING_SET, + OP_STRING_LENGTH, OP_MAKE_PROCEDURE, OP_MAKE_VECTOR, OP_NULLP, @@ -107,6 +109,8 @@ enum opcode_names { OP_LE, OP_EQV, OP_EQ, + OP_CHAR2INT, + OP_INT2CHAR, OP_DISPLAY, OP_WRITE, OP_WRITE_CHAR, diff --git a/init.scm b/init.scm index e3210566..93393e02 100644 --- a/init.scm +++ b/init.scm @@ -1,30 +1,26 @@ -;; cond case delay do -;; quasiquote let-syntax -;; letrec-syntax syntax-rules not boolean? number? -;; complex? real? rational? integer? exact? inexact? -;; positive? negative? odd? even? max min quotient remainder -;; modulo numerator denominator floor ceiling truncate round +;; let-syntax letrec-syntax syntax-rules +;; number? complex? real? rational? integer? exact? inexact? +;; positive? negative? max min remainder +;; modulo numerator denominator ;; rationalize expt ;; make-rectangular make-polar real-part imag-part magnitude angle ;; exact->inexact inexact->exact number->string string->number ;; symbol->string string->symbol ;; char-alphabetic? char-numeric? char-whitespace? -;; char-upper-case? char-lower-case? char->integer integer->char -;; char-upcase char-downcase make-string string string-length +;; char-upper-case? char-lower-case? +;; char-upcase char-downcase make-string ;; string=? string-ci=? string? ;; string<=? string>=? string-ci? string-ci<=? string-ci>=? -;; substring string-append string->list list->string string-copy -;; string-fill! vector vector-length -;; vector->list list->vector vector-fill! procedure? apply -;; map for-each force call-with-current-continuation values -;; call-with-values dynamic-wind scheme-report-environment -;; null-environment call-with-input-file call-with-output-file -;; current-input-port current-output-port -;; with-input-from-file with-output-to-file open-input-file -;; open-output-file close-input-port close-output-port +;; substring string-append string-copy +;; values call-with-values dynamic-wind +;; call-with-input-file call-with-output-file +;; with-input-from-file with-output-to-file ;; peek-char char-ready? +(define (not x) (if x #f #t)) +(define (boolean? x) (if (eq? x #t) #t (eq? x #f))) + ;; provide c[ad]{2,4}r (define (caar x) (car (car x))) @@ -61,7 +57,7 @@ (define (list . args) args) (define (list-tail ls k) - (if (zero? k) + (if (eq? k 0) ls (list-tail (cdr ls) (- k 1)))) @@ -82,8 +78,8 @@ (if (null? ls) #f (if (equal? obj (caar ls)) - ls - (member obj (cdr ls))))) + (car ls) + (assoc obj (cdr ls))))) (define assv assoc) @@ -105,27 +101,21 @@ ;; map with a fast-path for single lists (define (map proc ls . lol) + (define (map1 proc ls res) + (if (pair? ls) + (map1 proc (cdr ls) (cons (proc (car ls)) res)) + (reverse res))) + (define (mapn proc lol res) + (if (null? (car lol)) + (reverse res) + (mapn proc + (map1 cdr lol '()) + (cons (apply1 proc (map1 car lol '())) res)))) (if (null? lol) (map1 proc ls '()) (mapn proc (cons ls lol) '()))) -(define (map1 proc ls res) - (if (pair? ls) - (map1 proc (cdr ls) (cons (proc (car ls)) res)) - (reverse res))) - -(define (mapn proc lol res) - (if (null? (car lol)) - (reverse res) - (mapn proc - (map1 cdr lol '()) - (cons (apply1 proc (map1 car lol '())) res)))) - -;; math utilities - -(define (zero? x) (= x 0)) -(define (positive? x) (> x 0)) -(define (negative? x) (< x 0)) +(define for-each map) ;; syntax @@ -156,37 +146,6 @@ '()) (lambda (x y) (identifier=? use-env x use-env y)))))) -(define-syntax letrec - (er-macro-transformer - (lambda (expr rename compare) - (list - (cons (rename 'lambda) - (cons '() - (append (map (lambda (x) (cons (rename 'define) x)) (cadr expr)) - (cddr expr)))))))) - -(define-syntax let - (er-macro-transformer - (lambda (expr rename compare) - (if (identifier? (cadr expr)) - (list (rename 'letrec) - (list (list (cadr expr) - (cons (rename 'lambda) - (cons (map car (caddr expr)) - (cdddr expr))))) - (cons (cadr expr) (map cadr (caddr expr)))) - (cons (cons (rename 'lambda) (cons (map car (cadr expr)) (cddr expr))) - (map cadr (cadr expr))))))) - -(define-syntax let* - (er-macro-transformer - (lambda (expr rename compare) - (if (null? (cadr expr)) - (cons (rename 'begin) (cddr expr)) - (list (rename 'let) - (list (caadr expr)) - (cons (rename 'let*) (cons (cdadr expr) (cddr expr)))))))) - (define-syntax or (er-macro-transformer (lambda (expr rename compare) @@ -213,52 +172,134 @@ (lambda (expr rename compare) (if (null? (cdr expr)) #f - (let ((cl (cadr expr))) - (if (eq? 'else (car cl)) - (cons (rename 'begin) (cdr cl)) - (if (if (null? (cdr cl)) #t (eq? '=> (cadr cl))) - (list (rename 'let) - (list (list (rename 'tmp) (car cl))) - (list (rename 'if) (rename 'tmp) - (if (null? (cdr cl)) - (rename 'tmp) - (list (caddr cl) (rename 'tmp))))) - (list (rename 'if) - (car cl) - (cons (rename 'begin) (cdr cl)) - (cons (rename 'cond) (cddr expr)))))))))) + ((lambda (cl) + (if (compare 'else (car cl)) + (cons (rename 'begin) (cdr cl)) + (if (if (null? (cdr cl)) #t (compare '=> (cadr cl))) + (list (rename 'let) + (list (list (rename 'tmp) (car cl))) + (list (rename 'if) (rename 'tmp) + (if (null? (cdr cl)) + (rename 'tmp) + (list (caddr cl) (rename 'tmp))))) + (list (rename 'if) + (car cl) + (cons (rename 'begin) (cdr cl)) + (cons (rename 'cond) (cddr expr)))))) + (cadr expr)))))) (define-syntax quasiquote (er-macro-transformer (lambda (expr rename compare) (define (qq x d) - (if (pair? x) - (if (eq? 'unquote (car x)) - (if (<= d 0) - (cadr x) - (list (rename 'unquote) (qq (cadr x) (- d 1)))) - (if (eq? 'unquote-splicing (car x)) - (if (<= d 0) - (list (rename 'cons) (qq (car x) d) (qq (cdr x) d)) - (list (rename 'unquote-splicing) (qq (cadr x) (- d 1)))) - (if (eq? 'quasiquote (car x)) - (list (rename 'quasiquote) (qq (cadr x) (+ d 1))) - (if (and (<= d 0) - (pair? (car x)) - (eq? 'unquote-splicing (caar x))) - (list (rename 'append) - (cadar x) - (qq (cdr x) d)) - (list (rename 'cons) - (qq (car x) d) - (qq (cdr x) d)))))) - (if (vector? x) - (list (rename 'list->vector) (qq (vector->list x) d)) - (if (symbol? x) - (list (rename 'quote) x) - x)))) + (cond + ((pair? x) + (cond + ((eq? 'unquote (car x)) + (if (<= d 0) + (cadr x) + (list (rename 'unquote) (qq (cadr x) (- d 1))))) + ((eq? 'unquote-splicing (car x)) + (if (<= d 0) + (list (rename 'cons) (qq (car x) d) (qq (cdr x) d)) + (list (rename 'unquote-splicing) (qq (cadr x) (- d 1))))) + ((eq? 'quasiquote (car x)) + (list (rename 'quasiquote) (qq (cadr x) (+ d 1)))) + ((and (<= d 0) (pair? (car x)) (eq? 'unquote-splicing (caar x))) + (if (null? (cdr x)) + (cadar x) + (list (rename 'append) (cadar x) (qq (cdr x) d)))) + (else + (list (rename 'cons) (qq (car x) d) (qq (cdr x) d))))) + ((vector? x) (list (rename 'list->vector) (qq (vector->list x) d))) + ((symbol? x) (list (rename 'quote) x)) + (else x))) (qq (cadr expr) 0)))) +(define-syntax letrec + (er-macro-transformer + (lambda (expr rename compare) + ((lambda (defs) + `((,(rename 'lambda) () ,@defs ,@(cddr expr)))) + (map (lambda (x) (cons (rename 'define) x)) (cadr expr)))))) + +(define-syntax let + (er-macro-transformer + (lambda (expr rename compare) + (if (identifier? (cadr expr)) + `(,(rename 'letrec) ((,(cadr expr) + (,(rename 'lambda) ,(map car (caddr expr)) + ,@(cdddr expr)))) + ,(cons (cadr expr) (map cadr (caddr expr)))) + `((,(rename 'lambda) ,(map car (cadr expr)) ,@(cddr expr)) + ,@(map cadr (cadr expr))))))) + +(define-syntax let* + (er-macro-transformer + (lambda (expr rename compare) + (if (null? (cadr expr)) + `(,(rename 'begin) ,@(cddr expr)) + `(,(rename 'let) (,(caadr expr)) + (,(rename 'let*) ,(cdadr expr) ,@(cddr expr))))))) + +(define-syntax case + (er-macro-transformer + (lambda (expr rename compare) + (define (clause ls) + (cond + ((null? ls) #f) + ((compare 'else (caar ls)) + `(,(rename 'begin) ,@(cdar ls))) + (else + (if (and (pair? (caar ls)) (null? (cdaar ls))) + `(,(rename 'if) (,(rename 'eqv?) ,(rename 'tmp) ',(caaar ls)) + (,(rename 'begin) ,@(cdar ls)) + ,(clause (cdr ls))) + `(,(rename 'if) (,(rename 'memv) ,(rename 'tmp) ',(caar ls)) + (,(rename 'begin) ,@(cdar ls)) + ,(clause (cdr ls))))))) + `(let ((,(rename 'tmp) ,(cadr expr))) + ,(clause (cddr expr)))))) + +(define-syntax do + (er-macro-transformer + (lambda (expr rename compare) + (let* ((body + `(,(rename 'begin) + ,@(cdddr expr) + (,(rename 'lp) + ,@(map (lambda (x) (if (pair? (cddr x)) (caddr x) (car x))) + (cadr expr))))) + (check (caddr expr)) + (wrap + (if (null? (cdr check)) + `(,(rename 'let) ((,(rename 'tmp) ,(car check))) + (,(rename 'if) ,(rename 'tmp) + ,(rename 'tmp) + ,body)) + `(,(rename 'if) ,(car check) + (,(rename 'begin) ,@(cdr check)) + ,body)))) + `(,(rename 'let) ,(rename 'lp) + ,(map (lambda (x) (list (car x) (cadr x))) (cadr expr)) + ,wrap))))) + +(define-syntax delay + (er-macro-transformer + (lambda (expr rename compare) + `(,(rename 'make-promise) (,(rename 'lambda) () ,(cadr epr)))))) + +(define (make-promise thunk) + (lambda () + (let ((computed? #f) (result #f)) + (if (not computed?) + (begin + (set! result (thunk)) + (set! computed? #t))) + result))) + +(define (force x) (if (procedure? x) (x) x)) + ;; char utils ;; (define (char=? a b) (= (char->integer a) (char->integer b))) @@ -278,24 +319,35 @@ ;; (define (char-ci>=? a b) ;; (>= (char->integer (char-downcase a)) (char->integer (char-downcase b)))) -;; vector utils +;; string utils -(define (list->vector ls) - (let ((vec (make-vector (length ls)))) +(define (list->string ls) + (let ((str (make-string (length ls) #\space))) (let lp ((ls ls) (i 0)) (if (pair? ls) (begin - (vector-set! vec i (car ls)) + (string-set! str i (car ls)) (lp (cdr ls) (+ i 1))))) - vec)) + str)) -(define (vector->list vec) - (let lp ((i (- (vector-length vec) 1)) (res '())) - (if (< i 0) - res - (lp (- i 1) (cons (vector-ref vec i) res))))) +(define (string->list str) + (let lp ((i (- (string-length str) 1)) (res '())) + (if (< i 0) res (lp (- i 1) (cons (string-ref str i) res))))) -;; math +(define (string-fill! str ch) + (let lp ((i (- (string-length str) 1))) + (if (>= i 0) (begin (string-set! str i ch) (lp (- i 1)))))) + +(define (string . args) (list->string args)) + +;; math utils + +(define (zero? x) (= x 0)) +(define (positive? x) (> x 0)) +(define (negative? x) (< x 0)) + +(define (even? n) (= (remainder n 2) 0)) +(define (odd? n) (= (remainder n 2) 1)) ;; (define (abs x) (if (< x 0) (- x) x)) @@ -307,5 +359,28 @@ ;; (define (lcm a b) ;; (quotient (* a b) (gcd a b))) +;; vector utils + +(define (list->vector ls) + (let ((vec (make-vector (length ls) #f))) + (let lp ((ls ls) (i 0)) + (if (pair? ls) + (begin + (vector-set! vec i (car ls)) + (lp (cdr ls) (+ i 1))))) + vec)) + +(define (vector->list vec) + (let lp ((i (- (vector-length vec) 1)) (res '())) + (if (< i 0) res (lp (- i 1) (cons (vector-ref vec i) res))))) + +(define (vector-fill! str ch) + (let lp ((i (- (vector-length str) 1))) + (if (>= i 0) (begin (vector-set! str i ch) (lp (- i 1)))))) + +(define (vector . args) (list->vector args)) + +;; miscellaneous + (define (load file) (%load file (interaction-environment))) diff --git a/opcodes.c b/opcodes.c index faac6fb3..608a0d6f 100644 --- a/opcodes.c +++ b/opcodes.c @@ -15,8 +15,12 @@ _OP(OPC_ACCESSOR, OP_CDR, 1, 0, SEXP_PAIR, 0, 0, "cdr", NULL, NULL), _OP(OPC_ACCESSOR, OP_SET_CDR, 2, 0, SEXP_PAIR, 0, 0, "set-cdr!", NULL, NULL), _OP(OPC_ACCESSOR, OP_VECTOR_REF,2,0, SEXP_VECTOR, SEXP_FIXNUM, 0,"vector-ref", NULL, NULL), _OP(OPC_ACCESSOR, OP_VECTOR_SET,3,0, SEXP_VECTOR, SEXP_FIXNUM, 0,"vector-set!", NULL, NULL), +_OP(OPC_ACCESSOR, OP_VECTOR_LENGTH,1,0, SEXP_VECTOR, 0, 0,"vector-length", NULL, NULL), _OP(OPC_ACCESSOR, OP_STRING_REF,2,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-ref", NULL, NULL), _OP(OPC_ACCESSOR, OP_STRING_SET,3,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-set!", NULL, NULL), +_OP(OPC_ACCESSOR, OP_STRING_LENGTH,1,0, SEXP_STRING, 0, 0,"string-length", NULL, NULL), +_OP(OPC_GENERIC, OP_CHAR2INT, 1, 0, SEXP_CHAR, 0, 0, "char->integer", NULL, NULL), +_OP(OPC_GENERIC, OP_INT2CHAR, 1, 0, SEXP_FIXNUM, 0, 0, "integer->char", NULL, NULL), _OP(OPC_ARITHMETIC, OP_ADD, 0, 1, SEXP_FIXNUM, 0, 0, "+", NULL, NULL), _OP(OPC_ARITHMETIC, OP_MUL, 0, 1, SEXP_FIXNUM, 0, 0, "*", NULL, NULL), _OP(OPC_ARITHMETIC_INV, OP_SUB, 0, 1, SEXP_FIXNUM, 0, OP_NEG, "-", NULL, NULL), @@ -77,6 +81,10 @@ _FN1(0, "asin", sexp_asin), _FN1(0, "acos", sexp_acos), _FN1(0, "atan", sexp_atan), _FN1(0, "sqrt", sexp_sqrt), +_FN1(0, "round", sexp_round), +_FN1(0, "truncate", sexp_trunc), +_FN1(0, "floor", sexp_floor), +_FN1(0, "ceiling", sexp_ceiling), #endif _FN2(0, SEXP_PAIR, "memq", sexp_memq), _FN2(0, SEXP_PAIR, "assq", sexp_assq), diff --git a/sexp.c b/sexp.c index 65118d45..48d68cee 100644 --- a/sexp.c +++ b/sexp.c @@ -47,7 +47,7 @@ static int is_separator(int c) { static sexp* symbol_table = NULL; static unsigned long symbol_table_primes[] = { - 97, 389, 1543, 6151, 12289, 24593, 49157, 98317, 196613, 393241, + /* 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; @@ -934,6 +934,8 @@ void sexp_init() { sexp_initialized_p = 1; #if USE_BOEHM GC_init(); + GC_add_roots((char*)&symbol_table, + ((char*)&symbol_table)+sizeof(symbol_table)+1); #endif symbol_table = sexp_alloc(symbol_table_primes[0]*sizeof(sexp)); the_dot_symbol = sexp_intern("."); diff --git a/sexp.h b/sexp.h index a8f13150..f51a5de5 100644 --- a/sexp.h +++ b/sexp.h @@ -109,6 +109,7 @@ struct sexp_struct { } env; struct { sexp_uint_t length; + sexp literals; unsigned char data[]; } bytecode; struct { @@ -263,6 +264,7 @@ struct sexp_struct { #define sexp_bytecode_length(x) ((x)->value.bytecode.length) #define sexp_bytecode_data(x) ((x)->value.bytecode.data) +#define sexp_bytecode_literals(x) ((x)->value.bytecode.literals) #define sexp_env_flags(x) ((x)->value.env.flags) #define sexp_env_parent(x) ((x)->value.env.parent) From 553ac63a18337fb073e2a4f44de5b17ab365bf37 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 2 Apr 2009 14:38:23 +0900 Subject: [PATCH 077/154] adding expt and char utils --- debug.c | 19 ++++++++++--------- eval.c | 32 ++++++++++++++++++++++++++++++++ eval.h | 2 ++ init.scm | 39 ++++++++++++++++++++++++++------------- opcodes.c | 3 +++ sexp.h | 3 +++ 6 files changed, 76 insertions(+), 22 deletions(-) diff --git a/debug.c b/debug.c index 90d5c8db..f08e818a 100644 --- a/debug.c +++ b/debug.c @@ -3,16 +3,17 @@ /* BSD-style license: http://synthcode.com/license.txt */ static const char* reverse_opcode_names[] = - {"NOOP", "ERROR", "RESUMECC", "CALLCC", "APPLY1", "TAIL_CALL", "CALL", - "FCALL0", "FCALL1", "FCALL2", "FCALL3", "FCALL4", "EVAL", "JUMP_UNLESS", - "JUMP", "PUSH", "DROP", "STACK_REF", "LOCAL_REF", "LOCAL_SET", - "CLOSURE_REF", "VECTOR_REF", "VECTOR_SET", "VECTOR_LENGTH", - "STRING_REF", "STRING_SET", "STRING_LENGTH", - "MAKE_PROCEDURE", "MAKE_VECTOR", "NULLP", "INTEGERP", "SYMBOLP", "CHARP", - "EOFP", "TYPEP", "CAR", "CDR", "SET_CAR", "SET_CDR", "CONS", "ADD", "SUB", + {"NOOP", "ERROR", "RESUMECC", "CALLCC", "APPLY1", "TAIL-CALL", "CALL", + "FCALL0", "FCALL1", "FCALL2", "FCALL3", "FCALL4", "EVAL", "JUMP-UNLESS", + "JUMP", "PUSH", "DROP", "STACK-REF", "LOCAL-REF", "LOCAL-SET", + "CLOSURE-REF", "VECTOR-REF", "VECTOR-SET", "VECTOR-LENGTH", + "STRING-REF", "STRING-SET", "STRING-LENGTH", + "MAKE-PROCEDURE", "MAKE-VECTOR", "NULLP", "INTEGERP", "SYMBOLP", "CHARP", + "EOFP", "TYPEP", "CAR", "CDR", "SET-CAR", "SET-CDR", "CONS", "ADD", "SUB", "MUL", "DIV", "QUOT", "MOD", "NEG", "INV", "LT", "LE", "EQV", "EQ", - "CHAR->INTEGER", "INTEGER->CHAR", "DISPLAY", "WRITE", "WRITE_CHAR", - "NEWLINE", "FLUSH_OUTPUT", "READ", "READ_CHAR", "RET", "DONE", + "CHAR->INTEGER", "INTEGER->CHAR", "CHAR-UPCASE", "CHAR-DOWNCASE", + "DISPLAY", "WRITE", "WRITE-CHAR", + "NEWLINE", "FLUSH-OUTPUT", "READ", "READ-CHAR", "RET", "DONE", }; void disasm (sexp bc, sexp out) { diff --git a/eval.c b/eval.c index d6b4c8e8..ea8f8625 100644 --- a/eval.c +++ b/eval.c @@ -1336,6 +1336,12 @@ sexp vm(sexp bc, sexp cp, sexp context, sexp* stack, sexp_sint_t top) { case OP_INT2CHAR: _ARG1 = sexp_make_character(sexp_unbox_integer(_ARG1)); break; + case OP_CHAR_UPCASE: + _ARG1 = sexp_make_character(toupper(sexp_unbox_character(_ARG1))); + break; + case OP_CHAR_DOWNCASE: + _ARG1 = sexp_make_character(tolower(sexp_unbox_character(_ARG1))); + break; case OP_DISPLAY: if (sexp_stringp(_ARG1)) { sexp_write_string(sexp_string_data(_ARG1), _ARG2); @@ -1454,6 +1460,32 @@ define_math_op(sexp_ceiling, ceil) #endif +static sexp sexp_expt (sexp x, sexp e) { + double res, x1, e1; + if (sexp_integerp(x)) + x1 = (double)sexp_unbox_integer(x); +#if USE_FLONUMS + else if (sexp_flonump(x)) + x1 = sexp_flonum_value(x); +#endif + else + return sexp_math_exception("not a number", x); + if (sexp_integerp(e)) + e1 = (double)sexp_unbox_integer(e); +#if USE_FLONUMS + else if (sexp_flonump(e)) + e1 = sexp_flonum_value(e); +#endif + else + return sexp_math_exception("not a number", e); + res = pow(x1, e1); +#if USE_FLONUMS + if ((res > SEXP_MAX_INT) || sexp_flonump(x) || sexp_flonump(e)) + return sexp_make_flonum(res); +#endif + return sexp_make_integer((sexp_sint_t)round(res)); +} + /*********************** standard environment *************************/ static struct sexp_struct core_forms[] = { diff --git a/eval.h b/eval.h index 4c42af99..494c25fb 100644 --- a/eval.h +++ b/eval.h @@ -111,6 +111,8 @@ enum opcode_names { OP_EQ, OP_CHAR2INT, OP_INT2CHAR, + OP_CHAR_UPCASE, + OP_CHAR_DOWNCASE, OP_DISPLAY, OP_WRITE, OP_WRITE_CHAR, diff --git a/init.scm b/init.scm index 93393e02..3ab9d4f7 100644 --- a/init.scm +++ b/init.scm @@ -1,15 +1,12 @@ ;; let-syntax letrec-syntax syntax-rules ;; number? complex? real? rational? integer? exact? inexact? -;; positive? negative? max min remainder -;; modulo numerator denominator -;; rationalize expt -;; make-rectangular make-polar real-part imag-part magnitude angle +;; remainder modulo ;; exact->inexact inexact->exact number->string string->number ;; symbol->string string->symbol ;; char-alphabetic? char-numeric? char-whitespace? ;; char-upper-case? char-lower-case? -;; char-upcase char-downcase make-string +;; make-string ;; string=? string-ci=? string? ;; string<=? string>=? string-ci? string-ci<=? string-ci>=? ;; substring string-append string-copy @@ -345,19 +342,35 @@ (define (zero? x) (= x 0)) (define (positive? x) (> x 0)) (define (negative? x) (< x 0)) - (define (even? n) (= (remainder n 2) 0)) (define (odd? n) (= (remainder n 2) 1)) -;; (define (abs x) (if (< x 0) (- x) x)) +(define (abs x) (if (< x 0) (- x) x)) -;; (define (gcd a b) -;; (if (= b 0) -;; a -;; (gcd b (modulo a b)))) +(define (gcd a b) + (if (= b 0) + a + (gcd b (modulo a b)))) -;; (define (lcm a b) -;; (quotient (* a b) (gcd a b))) +(define (lcm a b) + (quotient (* a b) (gcd a b))) + +(define (max x . rest) + (let lp ((hi x) (ls rest)) + (if (null? ls) + hi + (lp (if (> (car ls) hi) (car ls) hi) (cdr ls))))) + +(define (min x . rest) + (let lp ((lo x) (ls rest)) + (if (null? ls) + lo + (lp (if (< (car ls) lo) (car ls) lo) (cdr ls))))) + +(define (real-part z) z) +(define (imag-part z) 0.0) +(define magnitude abs) +(define (angle z) (if (< z 0) 3.141592653589793 0)) ;; vector utils diff --git a/opcodes.c b/opcodes.c index 608a0d6f..1ada2e22 100644 --- a/opcodes.c +++ b/opcodes.c @@ -21,6 +21,8 @@ _OP(OPC_ACCESSOR, OP_STRING_SET,3,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-set!", _OP(OPC_ACCESSOR, OP_STRING_LENGTH,1,0, SEXP_STRING, 0, 0,"string-length", NULL, NULL), _OP(OPC_GENERIC, OP_CHAR2INT, 1, 0, SEXP_CHAR, 0, 0, "char->integer", NULL, NULL), _OP(OPC_GENERIC, OP_INT2CHAR, 1, 0, SEXP_FIXNUM, 0, 0, "integer->char", NULL, NULL), +_OP(OPC_GENERIC, OP_CHAR_UPCASE, 1, 0, SEXP_CHAR, 0, 0, "char-upcase", NULL, NULL), +_OP(OPC_GENERIC, OP_CHAR_DOWNCASE, 1, 0, SEXP_CHAR, 0, 0, "char-downcase", NULL, NULL), _OP(OPC_ARITHMETIC, OP_ADD, 0, 1, SEXP_FIXNUM, 0, 0, "+", NULL, NULL), _OP(OPC_ARITHMETIC, OP_MUL, 0, 1, SEXP_FIXNUM, 0, 0, "*", NULL, NULL), _OP(OPC_ARITHMETIC_INV, OP_SUB, 0, 1, SEXP_FIXNUM, 0, OP_NEG, "-", NULL, NULL), @@ -85,6 +87,7 @@ _FN1(0, "round", sexp_round), _FN1(0, "truncate", sexp_trunc), _FN1(0, "floor", sexp_floor), _FN1(0, "ceiling", sexp_ceiling), +_FN2(0, 0, "expt", sexp_expt), #endif _FN2(0, SEXP_PAIR, "memq", sexp_memq), _FN2(0, SEXP_PAIR, "assq", sexp_assq), diff --git a/sexp.h b/sexp.h index f51a5de5..04c67fd1 100644 --- a/sexp.h +++ b/sexp.h @@ -38,6 +38,9 @@ #define SEXP_CHAR_TAG 6 #define SEXP_EXTENDED_TAG 14 +#define SEXP_MAX_INT ((1<<29)-1) +#define SEXP_MIN_INT (-(1<<29)) + enum sexp_types { SEXP_OBJECT, SEXP_FIXNUM, From 26eacabad9e2379241462c7148bd8ff14dca7367 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 2 Apr 2009 16:19:52 +0900 Subject: [PATCH 078/154] handling exact/inexact distinction better --- debug.c | 11 +++---- eval.c | 62 ++++++++++++++++++++++++++++++++++++---- eval.h | 8 ++---- init.scm | 85 ++++++++++++++++++++++++++++++------------------------- opcodes.c | 6 +++- sexp.c | 5 +++- sexp.h | 5 ++++ 7 files changed, 126 insertions(+), 56 deletions(-) diff --git a/debug.c b/debug.c index f08e818a..50fa6cb7 100644 --- a/debug.c +++ b/debug.c @@ -6,11 +6,12 @@ static const char* reverse_opcode_names[] = {"NOOP", "ERROR", "RESUMECC", "CALLCC", "APPLY1", "TAIL-CALL", "CALL", "FCALL0", "FCALL1", "FCALL2", "FCALL3", "FCALL4", "EVAL", "JUMP-UNLESS", "JUMP", "PUSH", "DROP", "STACK-REF", "LOCAL-REF", "LOCAL-SET", - "CLOSURE-REF", "VECTOR-REF", "VECTOR-SET", "VECTOR-LENGTH", - "STRING-REF", "STRING-SET", "STRING-LENGTH", - "MAKE-PROCEDURE", "MAKE-VECTOR", "NULLP", "INTEGERP", "SYMBOLP", "CHARP", - "EOFP", "TYPEP", "CAR", "CDR", "SET-CAR", "SET-CDR", "CONS", "ADD", "SUB", - "MUL", "DIV", "QUOT", "MOD", "NEG", "INV", "LT", "LE", "EQV", "EQ", + "CLOSURE-REF", "VECTOR-REF", "VECTOR-SET", "VECTOR-LENGTH", "STRING-REF", + "STRING-SET", "STRING-LENGTH", "MAKE-PROCEDURE", "MAKE-VECTOR", "NULL?", + "FIXNUM?", "SYMBOL?", "CHAR?", + "EOF?", "TYPEP", "CAR", "CDR", "SET-CAR", "SET-CDR", "CONS", "ADD", "SUB", + "MUL", "DIV", "QUOT", "MOD", "NEG", "INV", "LT", "LE", "EQN", "EQ", + "EXACT->INEXACT", "INEXACT->EXACT", "CHAR->INTEGER", "INTEGER->CHAR", "CHAR-UPCASE", "CHAR-DOWNCASE", "DISPLAY", "WRITE", "WRITE-CHAR", "NEWLINE", "FLUSH-OUTPUT", "READ", "READ-CHAR", "RET", "DONE", diff --git a/eval.c b/eval.c index ea8f8625..0bcb1d7e 100644 --- a/eval.c +++ b/eval.c @@ -1316,20 +1316,72 @@ sexp vm(sexp bc, sexp cp, sexp context, sexp* stack, sexp_sint_t top) { else sexp_raise("/: not a number", sexp_list1(_ARG1)); break; case OP_LT: - _ARG2 = sexp_make_boolean(sexp_unbox_integer(_ARG1) - < sexp_unbox_integer(_ARG2)); + if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) + i = _ARG1 < _ARG2; +#if USE_FLONUMS + else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) + i = sexp_flonum_value(_ARG1) < sexp_flonum_value(_ARG2); + else if (sexp_flonump(_ARG1) && sexp_integerp(_ARG2)) + i = sexp_flonum_value(_ARG1) < (double)sexp_unbox_integer(_ARG2); + else if (sexp_integerp(_ARG1) && sexp_flonump(_ARG2)) + i = (double)sexp_unbox_integer(_ARG1) < sexp_flonum_value(_ARG2); +#endif + else sexp_raise("<: not a number", sexp_list2(_ARG1, _ARG2)); + _ARG2 = sexp_make_boolean(i); top--; break; case OP_LE: - _ARG2 = sexp_make_boolean(sexp_unbox_integer(_ARG1) - <= sexp_unbox_integer(_ARG2)); + if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) + i = _ARG1 <= _ARG2; +#if USE_FLONUMS + else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) + i = sexp_flonum_value(_ARG1) <= sexp_flonum_value(_ARG2); + else if (sexp_flonump(_ARG1) && sexp_integerp(_ARG2)) + i = sexp_flonum_value(_ARG1) <= (double)sexp_unbox_integer(_ARG2); + else if (sexp_integerp(_ARG1) && sexp_flonump(_ARG2)) + i = (double)sexp_unbox_integer(_ARG1) <= sexp_flonum_value(_ARG2); +#endif + else sexp_raise("<=: not a number", sexp_list2(_ARG1, _ARG2)); + _ARG2 = sexp_make_boolean(i); + top--; + break; + case OP_EQN: + if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) + i = _ARG1 == _ARG2; +#if USE_FLONUMS + else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) + i = sexp_flonum_value(_ARG1) == sexp_flonum_value(_ARG2); + else if (sexp_flonump(_ARG1) && sexp_integerp(_ARG2)) + i = sexp_flonum_value(_ARG1) == (double)sexp_unbox_integer(_ARG2); + else if (sexp_integerp(_ARG1) && sexp_flonump(_ARG2)) + i = (double)sexp_unbox_integer(_ARG1) == sexp_flonum_value(_ARG2); +#endif + else sexp_raise("=: not a number", sexp_list2(_ARG1, _ARG2)); + _ARG2 = sexp_make_boolean(i); top--; break; case OP_EQ: - case OP_EQV: _ARG2 = sexp_make_boolean(_ARG1 == _ARG2); top--; break; + case OP_FIX2FLO: + if (sexp_integerp(_ARG1)) + _ARG1 = sexp_integer_to_flonum(_ARG1); + else +#if USE_FLONUMS + if (! sexp_flonump(_ARG1)) +#endif + sexp_raise("exact->inexact: not a number", sexp_list1(_ARG1)); + break; + case OP_FLO2FIX: +#if USE_FLONUMS + if (sexp_flonump(_ARG1)) + _ARG1 = sexp_make_integer((sexp_sint_t)sexp_flonum_value(_ARG1)); + else +#endif + if (! sexp_integerp(_ARG1)) + sexp_raise("inexact->exact: not a number", sexp_list1(_ARG1)); + break; case OP_CHAR2INT: _ARG1 = sexp_make_integer(sexp_unbox_character(_ARG1)); break; diff --git a/eval.h b/eval.h index 494c25fb..8a7a791b 100644 --- a/eval.h +++ b/eval.h @@ -7,10 +7,6 @@ #include "sexp.h" -#if USE_MATH -#include -#endif - /************************* additional types ***************************/ #define INIT_BCODE_SIZE 128 @@ -107,8 +103,10 @@ enum opcode_names { OP_INV, OP_LT, OP_LE, - OP_EQV, + OP_EQN, OP_EQ, + OP_FIX2FLO, + OP_FLO2FIX, OP_CHAR2INT, OP_INT2CHAR, OP_CHAR_UPCASE, diff --git a/init.scm b/init.scm index 3ab9d4f7..78332557 100644 --- a/init.scm +++ b/init.scm @@ -1,8 +1,7 @@ ;; let-syntax letrec-syntax syntax-rules -;; number? complex? real? rational? integer? exact? inexact? ;; remainder modulo -;; exact->inexact inexact->exact number->string string->number +;; number->string string->number ;; symbol->string string->symbol ;; char-alphabetic? char-numeric? char-whitespace? ;; char-upper-case? char-lower-case? @@ -15,16 +14,12 @@ ;; with-input-from-file with-output-to-file ;; peek-char char-ready? -(define (not x) (if x #f #t)) -(define (boolean? x) (if (eq? x #t) #t (eq? x #f))) - ;; provide c[ad]{2,4}r (define (caar x) (car (car x))) (define (cadr x) (car (cdr x))) (define (cdar x) (cdr (car x))) (define (cddr x) (cdr (cdr x))) - (define (caaar x) (car (car (car x)))) (define (caadr x) (car (car (cdr x)))) (define (cadar x) (car (cdr (car x)))) @@ -33,23 +28,22 @@ (define (cdadr x) (cdr (car (cdr x)))) (define (cddar x) (cdr (cdr (car x)))) (define (cdddr x) (cdr (cdr (cdr x)))) - -;; (define (caaaar x) (car (car (car (car x))))) -;; (define (caaadr x) (car (car (car (cdr x))))) -;; (define (caadar x) (car (car (cdr (car x))))) -;; (define (caaddr x) (car (car (cdr (cdr x))))) -;; (define (cadaar x) (car (cdr (car (car x))))) -;; (define (cadadr x) (car (cdr (car (cdr x))))) -;; (define (caddar x) (car (cdr (cdr (car x))))) -;; (define (cadddr x) (car (cdr (cdr (cdr x))))) -;; (define (cdaaar x) (cdr (car (car (car x))))) -;; (define (cdaadr x) (cdr (car (car (cdr x))))) -;; (define (cdadar x) (cdr (car (cdr (car x))))) -;; (define (cdaddr x) (cdr (car (cdr (cdr x))))) -;; (define (cddaar x) (cdr (cdr (car (car x))))) -;; (define (cddadr x) (cdr (cdr (car (cdr x))))) -;; (define (cdddar x) (cdr (cdr (cdr (car x))))) -;; (define (cddddr x) (cdr (cdr (cdr (cdr x))))) +(define (caaaar x) (car (car (car (car x))))) +(define (caaadr x) (car (car (car (cdr x))))) +(define (caadar x) (car (car (cdr (car x))))) +(define (caaddr x) (car (car (cdr (cdr x))))) +(define (cadaar x) (car (cdr (car (car x))))) +(define (cadadr x) (car (cdr (car (cdr x))))) +(define (caddar x) (car (cdr (cdr (car x))))) +(define (cadddr x) (car (cdr (cdr (cdr x))))) +(define (cdaaar x) (cdr (car (car (car x))))) +(define (cdaadr x) (cdr (car (car (cdr x))))) +(define (cdadar x) (cdr (car (cdr (car x))))) +(define (cdaddr x) (cdr (car (cdr (cdr x))))) +(define (cddaar x) (cdr (cdr (car (car x))))) +(define (cddadr x) (cdr (cdr (car (cdr x))))) +(define (cdddar x) (cdr (cdr (cdr (car x))))) +(define (cddddr x) (cdr (cdr (cdr (cdr x))))) (define (list . args) args) @@ -60,7 +54,7 @@ (define (list-ref ls k) (car (list-tail ls k))) -(define eqv? equal?) +(define (eqv? a b) (if (eq? a b) #t (and (flonum? a) (flonum? b) (= a b)))) (define (member obj ls) (if (null? ls) @@ -297,24 +291,29 @@ (define (force x) (if (procedure? x) (x) x)) +;; booleans + +(define (not x) (if x #f #t)) +(define (boolean? x) (if (eq? x #t) #t (eq? x #f))) + ;; char utils -;; (define (char=? a b) (= (char->integer a) (char->integer b))) -;; (define (charinteger a) (char->integer b))) -;; (define (char>? a b) (> (char->integer a) (char->integer b))) -;; (define (char<=? a b) (<= (char->integer a) (char->integer b))) -;; (define (char>=? a b) (>= (char->integer a) (char->integer b))) +(define (char=? a b) (= (char->integer a) (char->integer b))) +(define (charinteger a) (char->integer b))) +(define (char>? a b) (> (char->integer a) (char->integer b))) +(define (char<=? a b) (<= (char->integer a) (char->integer b))) +(define (char>=? a b) (>= (char->integer a) (char->integer b))) -;; (define (char-ci=? a b) -;; (= (char->integer (char-downcase a)) (char->integer (char-downcase b)))) -;; (define (char-ciinteger (char-downcase a)) (char->integer (char-downcase b)))) -;; (define (char-ci>? a b) -;; (> (char->integer (char-downcase a)) (char->integer (char-downcase b)))) -;; (define (char-ci<=? a b) -;; (<= (char->integer (char-downcase a)) (char->integer (char-downcase b)))) -;; (define (char-ci>=? a b) -;; (>= (char->integer (char-downcase a)) (char->integer (char-downcase b)))) +(define (char-ci=? a b) + (= (char->integer (char-downcase a)) (char->integer (char-downcase b)))) +(define (char-ciinteger (char-downcase a)) (char->integer (char-downcase b)))) +(define (char-ci>? a b) + (> (char->integer (char-downcase a)) (char->integer (char-downcase b)))) +(define (char-ci<=? a b) + (<= (char->integer (char-downcase a)) (char->integer (char-downcase b)))) +(define (char-ci>=? a b) + (>= (char->integer (char-downcase a)) (char->integer (char-downcase b)))) ;; string utils @@ -339,6 +338,14 @@ ;; math utils +(define (number? x) (if (fixnum? x) #t (flonum? x))) +(define complex? number?) +(define rational? number?) +(define real? number?) +(define exact? fixnum?) +(define inexact? flonum?) +(define (integer? x) (if (fixnum? x) #t (and (flonum? x) (= x (truncate x))))) + (define (zero? x) (= x 0)) (define (positive? x) (> x 0)) (define (negative? x) (< x 0)) diff --git a/opcodes.c b/opcodes.c index 1ada2e22..813c4d37 100644 --- a/opcodes.c +++ b/opcodes.c @@ -19,6 +19,8 @@ _OP(OPC_ACCESSOR, OP_VECTOR_LENGTH,1,0, SEXP_VECTOR, 0, 0,"vector-length", NULL, _OP(OPC_ACCESSOR, OP_STRING_REF,2,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-ref", NULL, NULL), _OP(OPC_ACCESSOR, OP_STRING_SET,3,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-set!", NULL, NULL), _OP(OPC_ACCESSOR, OP_STRING_LENGTH,1,0, SEXP_STRING, 0, 0,"string-length", NULL, NULL), +_OP(OPC_GENERIC, OP_FIX2FLO, 1, 0, 0, 0, 0, "exact->inexact", NULL, NULL), +_OP(OPC_GENERIC, OP_FLO2FIX, 1, 0, 0, 0, 0, "inexact->exact", NULL, NULL), _OP(OPC_GENERIC, OP_CHAR2INT, 1, 0, SEXP_CHAR, 0, 0, "char->integer", NULL, NULL), _OP(OPC_GENERIC, OP_INT2CHAR, 1, 0, SEXP_FIXNUM, 0, 0, "integer->char", NULL, NULL), _OP(OPC_GENERIC, OP_CHAR_UPCASE, 1, 0, SEXP_CHAR, 0, 0, "char-upcase", NULL, NULL), @@ -33,7 +35,7 @@ _OP(OPC_ARITHMETIC_CMP, OP_LT, 0, 1, SEXP_FIXNUM, 0, 0, "<", NULL, NULL), _OP(OPC_ARITHMETIC_CMP, OP_LE, 0, 1, SEXP_FIXNUM, 0, 0, "<=", NULL, NULL), _OP(OPC_ARITHMETIC_CMP, OP_LT, 0, 1, SEXP_FIXNUM, 0, 1, ">", NULL, NULL), _OP(OPC_ARITHMETIC_CMP, OP_LE, 0, 1, SEXP_FIXNUM, 0, 1, ">=", NULL, NULL), -_OP(OPC_ARITHMETIC_CMP, OP_EQ, 0, 1, SEXP_FIXNUM, 0, 0, "=", NULL, NULL), +_OP(OPC_ARITHMETIC_CMP, OP_EQN, 0, 1, SEXP_FIXNUM, 0, 0, "=", NULL, NULL), _OP(OPC_PREDICATE, OP_EQ, 2, 0, 0, 0, 0, "eq?", NULL, NULL), _OP(OPC_CONSTRUCTOR, OP_CONS, 2, 0, 0, 0, 0, "cons", NULL, NULL), _OP(OPC_CONSTRUCTOR, OP_MAKE_VECTOR, 2, 0, SEXP_FIXNUM, 0, 0, "make-vector", NULL, NULL), @@ -42,9 +44,11 @@ _OP(OPC_TYPE_PREDICATE, OP_NULLP, 1, 0, 0, 0, 0, "null?", NULL, NULL), _OP(OPC_TYPE_PREDICATE, OP_EOFP, 1, 0, 0, 0, 0, "eof-object?", NULL, NULL), _OP(OPC_TYPE_PREDICATE, OP_SYMBOLP, 1, 0, 0, 0, 0, "symbol?", NULL, NULL), _OP(OPC_TYPE_PREDICATE, OP_CHARP, 1, 0, 0, 0, 0, "char?", NULL, NULL), +_OP(OPC_TYPE_PREDICATE, OP_INTEGERP, 1, 0, 0, 0, 0, "fixnum?", NULL, NULL), _OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "pair?", (sexp)SEXP_PAIR, NULL), _OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "string?", (sexp)SEXP_STRING, NULL), _OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "vector?", (sexp)SEXP_VECTOR, NULL), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "flonum?", (sexp)SEXP_FLONUM, NULL), _OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "procedure?", (sexp)SEXP_PROCEDURE, NULL), _OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "input-port?", (sexp)SEXP_IPORT, NULL), _OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "output-port?", (sexp)SEXP_OPORT, NULL), diff --git a/sexp.c b/sexp.c index 48d68cee..fd55200a 100644 --- a/sexp.c +++ b/sexp.c @@ -449,6 +449,7 @@ sexp sexp_make_output_port(FILE* out) { void sexp_write (sexp obj, sexp out) { unsigned long len, c, res; long i=0; + double f; sexp x, *elts; char *str=NULL; @@ -485,7 +486,9 @@ void sexp_write (sexp obj, sexp out) { } break; case SEXP_FLONUM: - sexp_printf(out, "%g", sexp_flonum_value(obj)); break; + f = sexp_flonum_value(obj); + sexp_printf(out, "%.15g%s", f, (f == trunc(f)) ? ".0" : ""); + break; case SEXP_PROCEDURE: sexp_printf(out, "#", obj); break; case SEXP_IPORT: diff --git a/sexp.h b/sexp.h index 04c67fd1..4d46b3c6 100644 --- a/sexp.h +++ b/sexp.h @@ -11,6 +11,7 @@ #include #include #include +#include #include "config.h" #include "defaults.h" @@ -230,7 +231,11 @@ struct sexp_struct { #define sexp_flonum_value(f) ((f)->value.flonum) +#if USE_FLONUMS #define sexp_integer_to_flonum(x) (sexp_make_flonum(sexp_unbox_integer(x))) +#else +#define sexp_integer_to_flonum(x) (x) +#endif /*************************** field accessors **************************/ From a27fe20de9eb4e9a14e1961e080bbd00ce7774d7 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 2 Apr 2009 17:02:40 +0900 Subject: [PATCH 079/154] handling variadic comparison opcodes --- debug.c | 6 +- eval.c | 455 +++++++++++++++++++++++++++--------------------------- eval.h | 2 + init.scm | 17 +- opcodes.c | 1 + sexp.c | 4 + 6 files changed, 254 insertions(+), 231 deletions(-) diff --git a/debug.c b/debug.c index 50fa6cb7..6bdc8b01 100644 --- a/debug.c +++ b/debug.c @@ -7,14 +7,14 @@ static const char* reverse_opcode_names[] = "FCALL0", "FCALL1", "FCALL2", "FCALL3", "FCALL4", "EVAL", "JUMP-UNLESS", "JUMP", "PUSH", "DROP", "STACK-REF", "LOCAL-REF", "LOCAL-SET", "CLOSURE-REF", "VECTOR-REF", "VECTOR-SET", "VECTOR-LENGTH", "STRING-REF", - "STRING-SET", "STRING-LENGTH", "MAKE-PROCEDURE", "MAKE-VECTOR", "NULL?", - "FIXNUM?", "SYMBOL?", "CHAR?", + "STRING-SET", "STRING-LENGTH", "MAKE-PROCEDURE", "MAKE-VECTOR", "AND", + "NULL?", "FIXNUM?", "SYMBOL?", "CHAR?", "EOF?", "TYPEP", "CAR", "CDR", "SET-CAR", "SET-CDR", "CONS", "ADD", "SUB", "MUL", "DIV", "QUOT", "MOD", "NEG", "INV", "LT", "LE", "EQN", "EQ", "EXACT->INEXACT", "INEXACT->EXACT", "CHAR->INTEGER", "INTEGER->CHAR", "CHAR-UPCASE", "CHAR-DOWNCASE", "DISPLAY", "WRITE", "WRITE-CHAR", - "NEWLINE", "FLUSH-OUTPUT", "READ", "READ-CHAR", "RET", "DONE", + "NEWLINE", "FLUSH-OUTPUT", "READ", "READ-CHAR", "PEEK-CHAR", "RET", "DONE", }; void disasm (sexp bc, sexp out) { diff --git a/eval.c b/eval.c index 0bcb1d7e..dd242cd6 100644 --- a/eval.c +++ b/eval.c @@ -21,33 +21,10 @@ static sexp the_cur_in_symbol, the_cur_out_symbol, the_cur_err_symbol; #define disasm(...) #endif -/*************************** prototypes *******************************/ - static sexp analyze (sexp x, sexp context); -static sexp analyze_lambda (sexp x, sexp context); -static sexp analyze_seq (sexp ls, sexp context); -static sexp analyze_if (sexp x, sexp context); -static sexp analyze_app (sexp x, sexp context); -static sexp analyze_define (sexp x, sexp context); -static sexp analyze_var_ref (sexp x, sexp context); -static sexp analyze_set (sexp x, sexp context); -static sexp analyze_define_syntax (sexp x, sexp context); - static sexp_sint_t sexp_context_make_label (sexp context); static void sexp_context_patch_label (sexp context, sexp_sint_t label); static void generate (sexp x, sexp context); -static void generate_lit (sexp value, sexp context); -static void generate_seq (sexp app, sexp context); -static void generate_cnd (sexp cnd, sexp context); -static void generate_ref (sexp ref, sexp context, int unboxp); -static void generate_non_global_ref (sexp name, sexp loc, sexp lambda, - sexp fv, sexp context, int unboxp); -static void generate_set (sexp set, sexp context); -static void generate_app (sexp app, sexp context); -static void generate_opcode_app (sexp app, sexp context); -static void generate_general_app (sexp app, sexp context); -static void generate_lambda (sexp lambda, sexp context); - static sexp sexp_make_null_env (sexp version); static sexp sexp_make_standard_env (sexp version); @@ -320,6 +297,145 @@ static sexp sexp_compile_error(char *message, sexp irritants) { analyze_check_exception(var); \ } while (0) +static sexp analyze_app (sexp x, sexp context) { + sexp res=SEXP_NULL, tmp; + for ( ; sexp_pairp(x); x=sexp_cdr(x)) { + analyze_bind(tmp, sexp_car(x), context); + sexp_push(res, tmp); + } + return sexp_nreverse(res); +} + +static sexp analyze_seq (sexp ls, sexp context) { + sexp res, tmp; + if (sexp_nullp(ls)) + res = SEXP_UNDEF; + else if (sexp_nullp(sexp_cdr(ls))) + res = analyze(sexp_car(ls), context); + else { + res = sexp_alloc_type(seq, SEXP_SEQ); + tmp = analyze_app(ls, context); + analyze_check_exception(tmp); + sexp_seq_ls(res) = tmp; + } + return res; +} + +static sexp analyze_var_ref (sexp x, sexp context) { + sexp cell = env_cell(sexp_context_env(context), x); + if (! cell) { + if (sexp_synclop(x)) { + cell = env_cell_create(sexp_synclo_env(x), + sexp_synclo_expr(x), + SEXP_UNDEF); + x = sexp_synclo_expr(x); + } else { + cell = env_cell_create(sexp_context_env(context), x, SEXP_UNDEF); + } + } + return sexp_make_ref(x, cell); +} + +static sexp analyze_set (sexp x, sexp context) { + sexp ref, value; + ref = analyze_var_ref(sexp_cadr(x), context); + if (sexp_lambdap(sexp_ref_loc(ref))) + sexp_insert(sexp_lambda_sv(sexp_ref_loc(ref)), sexp_ref_name(ref)); + analyze_check_exception(ref); + analyze_bind(value, sexp_caddr(x), context); + return sexp_make_set(ref, value); +} + +static sexp analyze_lambda (sexp x, sexp context) { + sexp res, body, ls, tmp, name, value, defs=SEXP_NULL; + /* verify syntax */ + if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) + return sexp_compile_error("bad lambda syntax", sexp_list1(x)); + for (ls=sexp_cadr(x); sexp_pairp(ls); ls=sexp_cdr(ls)) + if (! sexp_idp(sexp_car(ls))) + return sexp_compile_error("non-symbol parameter", sexp_list1(x)); + else if (sexp_memq(sexp_car(ls), sexp_cdr(ls)) != SEXP_FALSE) + return sexp_compile_error("duplicate parameter", sexp_list1(x)); + /* build lambda and analyze body */ + res = sexp_make_lambda(sexp_cadr(x)); + context = sexp_child_context(context, res); + sexp_context_env(context) + = extend_env(sexp_context_env(context), + sexp_flatten_dot(sexp_lambda_params(res)), + res); + sexp_env_lambda(sexp_context_env(context)) = res; + body = analyze_seq(sexp_cddr(x), context); + analyze_check_exception(body); + /* delayed analyze internal defines */ + for (ls=sexp_lambda_defs(res); sexp_pairp(ls); ls=sexp_cdr(ls)) { + tmp = sexp_car(ls); + if (sexp_pairp(sexp_cadr(tmp))) { + name = sexp_caadr(tmp); + value = analyze_lambda(sexp_cons(SEXP_UNDEF, sexp_cons(sexp_cdadr(tmp), + sexp_cddr(tmp))), + context); + } else { + name = sexp_cadr(tmp); + value = analyze(sexp_caddr(tmp), context); + } + analyze_check_exception(value); + sexp_push(defs, sexp_make_set(analyze_var_ref(name, context), value)); + } + if (sexp_pairp(defs)) { + if (! sexp_seqp(body)) { + tmp = sexp_alloc_type(seq, SEXP_SEQ); + sexp_seq_ls(tmp) = sexp_list1(body); + body = tmp; + } + sexp_seq_ls(body) = sexp_append(defs, sexp_seq_ls(body)); + } + sexp_lambda_body(res) = body; + return res; +} + +static sexp analyze_if (sexp x, sexp context) { + sexp test, pass, fail, fail_expr; + analyze_bind(test, sexp_cadr(x), context); + analyze_bind(pass, sexp_caddr(x), context); + fail_expr = sexp_pairp(sexp_cdddr(x)) ? sexp_cadddr(x) : SEXP_UNDEF; + analyze_bind(fail, fail_expr, context); + return sexp_make_cnd(test, pass, fail); +} + +static sexp analyze_define (sexp x, sexp context) { + sexp ref, name, value, env = sexp_context_env(context); + name = (sexp_pairp(sexp_cadr(x)) ? sexp_caadr(x) : sexp_cadr(x)); + if (sexp_env_lambda(env) && sexp_lambdap(sexp_env_lambda(env))) { + sexp_push(sexp_env_bindings(env), + sexp_cons(name, sexp_context_lambda(context))); + sexp_push(sexp_lambda_sv(sexp_env_lambda(env)), name); + sexp_push(sexp_lambda_locals(sexp_env_lambda(env)), name); + sexp_push(sexp_lambda_defs(sexp_env_lambda(env)), x); + return SEXP_UNDEF; + } else { + env_cell_create(env, name, SEXP_DEF); + } + if (sexp_pairp(sexp_cadr(x))) + value = analyze_lambda(sexp_cons(SEXP_UNDEF, + sexp_cons(sexp_cdadr(x), sexp_cddr(x))), + context); + else + value = analyze(sexp_caddr(x), context); + analyze_check_exception(value); + ref = analyze_var_ref(name, context); + analyze_check_exception(ref); + return sexp_make_set(ref, value); +} + +static sexp analyze_define_syntax (sexp x, sexp context) { + sexp name = sexp_cadr(x), cell, proc; + proc = eval_in_context(sexp_caddr(x), context); + analyze_check_exception(proc); + cell = env_cell_create(sexp_context_env(context), name, SEXP_UNDEF); + sexp_cdr(cell) = sexp_make_macro(proc, sexp_context_env(context)); + return SEXP_UNDEF; +} + static sexp analyze (sexp x, sexp context) { sexp op, cell, res; loop: @@ -398,145 +514,6 @@ static sexp analyze (sexp x, sexp context) { return res; } -static sexp analyze_lambda (sexp x, sexp context) { - sexp res, body, ls, tmp, name, value, defs=SEXP_NULL; - /* verify syntax */ - if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) - return sexp_compile_error("bad lambda syntax", sexp_list1(x)); - for (ls=sexp_cadr(x); sexp_pairp(ls); ls=sexp_cdr(ls)) - if (! sexp_idp(sexp_car(ls))) - return sexp_compile_error("non-symbol parameter", sexp_list1(x)); - else if (sexp_memq(sexp_car(ls), sexp_cdr(ls)) != SEXP_FALSE) - return sexp_compile_error("duplicate parameter", sexp_list1(x)); - /* build lambda and analyze body */ - res = sexp_make_lambda(sexp_cadr(x)); - context = sexp_child_context(context, res); - sexp_context_env(context) - = extend_env(sexp_context_env(context), - sexp_flatten_dot(sexp_lambda_params(res)), - res); - sexp_env_lambda(sexp_context_env(context)) = res; - body = analyze_seq(sexp_cddr(x), context); - analyze_check_exception(body); - /* delayed analyze internal defines */ - for (ls=sexp_lambda_defs(res); sexp_pairp(ls); ls=sexp_cdr(ls)) { - tmp = sexp_car(ls); - if (sexp_pairp(sexp_cadr(tmp))) { - name = sexp_caadr(tmp); - value = analyze_lambda(sexp_cons(SEXP_UNDEF, sexp_cons(sexp_cdadr(tmp), - sexp_cddr(tmp))), - context); - } else { - name = sexp_cadr(tmp); - value = analyze(sexp_caddr(tmp), context); - } - analyze_check_exception(value); - sexp_push(defs, sexp_make_set(analyze_var_ref(name, context), value)); - } - if (sexp_pairp(defs)) { - if (! sexp_seqp(body)) { - tmp = sexp_alloc_type(seq, SEXP_SEQ); - sexp_seq_ls(tmp) = sexp_list1(body); - body = tmp; - } - sexp_seq_ls(body) = sexp_append(defs, sexp_seq_ls(body)); - } - sexp_lambda_body(res) = body; - return res; -} - -static sexp analyze_seq (sexp ls, sexp context) { - sexp res, tmp; - if (sexp_nullp(ls)) - res = SEXP_UNDEF; - else if (sexp_nullp(sexp_cdr(ls))) - res = analyze(sexp_car(ls), context); - else { - res = sexp_alloc_type(seq, SEXP_SEQ); - tmp = analyze_app(ls, context); - analyze_check_exception(tmp); - sexp_seq_ls(res) = tmp; - } - return res; -} - -static sexp analyze_if (sexp x, sexp context) { - sexp test, pass, fail, fail_expr; - analyze_bind(test, sexp_cadr(x), context); - analyze_bind(pass, sexp_caddr(x), context); - fail_expr = sexp_pairp(sexp_cdddr(x)) ? sexp_cadddr(x) : SEXP_UNDEF; - analyze_bind(fail, fail_expr, context); - return sexp_make_cnd(test, pass, fail); -} - -static sexp analyze_app (sexp x, sexp context) { - sexp res=SEXP_NULL, tmp; - for ( ; sexp_pairp(x); x=sexp_cdr(x)) { - analyze_bind(tmp, sexp_car(x), context); - sexp_push(res, tmp); - } - return sexp_nreverse(res); -} - -static sexp analyze_define (sexp x, sexp context) { - sexp ref, name, value, env = sexp_context_env(context); - name = (sexp_pairp(sexp_cadr(x)) ? sexp_caadr(x) : sexp_cadr(x)); - if (sexp_env_lambda(env) && sexp_lambdap(sexp_env_lambda(env))) { - sexp_push(sexp_env_bindings(env), - sexp_cons(name, sexp_context_lambda(context))); - sexp_push(sexp_lambda_sv(sexp_env_lambda(env)), name); - sexp_push(sexp_lambda_locals(sexp_env_lambda(env)), name); - sexp_push(sexp_lambda_defs(sexp_env_lambda(env)), x); - return SEXP_UNDEF; - } else { - env_cell_create(env, name, SEXP_DEF); - } - if (sexp_pairp(sexp_cadr(x))) - value = analyze_lambda(sexp_cons(SEXP_UNDEF, - sexp_cons(sexp_cdadr(x), sexp_cddr(x))), - context); - else - value = analyze(sexp_caddr(x), context); - analyze_check_exception(value); - ref = analyze_var_ref(name, context); - analyze_check_exception(ref); - return sexp_make_set(ref, value); -} - -static sexp analyze_var_ref (sexp x, sexp context) { - sexp cell = env_cell(sexp_context_env(context), x); - if (! cell) { - if (sexp_synclop(x)) { - cell = env_cell_create(sexp_synclo_env(x), - sexp_synclo_expr(x), - SEXP_UNDEF); - x = sexp_synclo_expr(x); - } else { - cell = env_cell_create(sexp_context_env(context), x, SEXP_UNDEF); - } - } - return sexp_make_ref(x, cell); -} - -static sexp analyze_set (sexp x, sexp context) { - sexp ref, value; - ref = analyze_var_ref(sexp_cadr(x), context); - if (sexp_lambdap(sexp_ref_loc(ref))) - sexp_insert(sexp_lambda_sv(sexp_ref_loc(ref)), sexp_ref_name(ref)); - analyze_check_exception(ref); - analyze_bind(value, sexp_caddr(x), context); - return sexp_make_set(ref, value); -} - -static sexp analyze_define_syntax (sexp x, sexp context) { - sexp name = sexp_cadr(x), cell, proc; - proc = eval_in_context(sexp_caddr(x), context); - analyze_check_exception(proc); - cell = env_cell_create(sexp_context_env(context), name, SEXP_UNDEF); - sexp_cdr(cell) = sexp_make_macro(proc, sexp_context_env(context)); - return SEXP_UNDEF; -} - static sexp_sint_t sexp_context_make_label (sexp context) { sexp_sint_t label = sexp_context_pos(context); sexp_context_pos(context) += sizeof(sexp_uint_t); @@ -559,38 +536,6 @@ static sexp finalize_bytecode (sexp context) { return sexp_context_bc(context); } -static void generate (sexp x, sexp context) { - if (sexp_pointerp(x)) { - switch (sexp_pointer_tag(x)) { - case SEXP_PAIR: - generate_app(x, context); - break; - case SEXP_LAMBDA: - generate_lambda(x, context); - break; - case SEXP_CND: - generate_cnd(x, context); - break; - case SEXP_REF: - generate_ref(x, context, 1); - break; - case SEXP_SET: - generate_set(x, context); - break; - case SEXP_SEQ: - generate_seq(sexp_seq_ls(x), context); - break; - case SEXP_LIT: - generate_lit(sexp_lit_value(x), context); - break; - default: - generate_lit(x, context); - } - } else { - generate_lit(x, context); - } -} - static void generate_lit (sexp value, sexp context) { emit_push(value, context); } @@ -626,20 +571,6 @@ static void generate_cnd (sexp cnd, sexp context) { sexp_context_patch_label(context, label2); } -static void generate_ref (sexp ref, sexp context, int unboxp) { - sexp lam; - if (! sexp_lambdap(sexp_ref_loc(ref))) { - /* global ref */ - emit_push(sexp_ref_cell(ref), context); - if (unboxp) - emit(OP_CDR, context); - } else { - lam = sexp_context_lambda(context); - generate_non_global_ref(sexp_ref_name(ref), sexp_ref_cell(ref), lam, - sexp_lambda_fv(lam), context, unboxp); - } -} - static void generate_non_global_ref (sexp name, sexp cell, sexp lambda, sexp fv, sexp context, int unboxp) { sexp_uint_t i; @@ -662,6 +593,20 @@ static void generate_non_global_ref (sexp name, sexp cell, sexp lambda, sexp_context_depth(context)++; } +static void generate_ref (sexp ref, sexp context, int unboxp) { + sexp lam; + if (! sexp_lambdap(sexp_ref_loc(ref))) { + /* global ref */ + emit_push(sexp_ref_cell(ref), context); + if (unboxp) + emit(OP_CDR, context); + } else { + lam = sexp_context_lambda(context); + generate_non_global_ref(sexp_ref_name(ref), sexp_ref_cell(ref), lam, + sexp_lambda_fv(lam), context, unboxp); + } +} + static void generate_set (sexp set, sexp context) { sexp ref = sexp_set_var(set), lambda; /* compile the value */ @@ -686,13 +631,6 @@ static void generate_set (sexp set, sexp context) { sexp_context_depth(context)--; } -static void generate_app (sexp app, sexp context) { - if (sexp_opcodep(sexp_car(app))) - generate_opcode_app(app, context); - else - generate_general_app(app, context); -} - static void generate_opcode_app (sexp app, sexp context) { sexp ls, op = sexp_car(app); sexp_sint_t i, num_args = sexp_unbox_integer(sexp_length(sexp_cdr(app))); @@ -722,6 +660,26 @@ static void generate_opcode_app (sexp app, sexp context) { emit((num_args == 1) ? sexp_opcode_inverse(op) : sexp_opcode_code(op), context); break; + case OPC_ARITHMETIC_CMP: + if (num_args > 2) { + emit(OP_STACK_REF, context); + emit_word(2, context); + emit(OP_STACK_REF, context); + emit_word(2, context); + emit(sexp_opcode_code(op), context); + emit(OP_AND, context); + for (i=num_args-2; i>0; i--) { + emit(OP_STACK_REF, context); + emit_word(3, context); + emit(OP_STACK_REF, context); + emit_word(3, context); + emit(sexp_opcode_code(op), context); + emit(OP_AND, context); + emit(OP_AND, context); + } + } else + emit(sexp_opcode_code(op), context); + break; case OPC_FOREIGN: case OPC_TYPE_PREDICATE: /* push the funtion pointer for foreign calls */ @@ -737,15 +695,11 @@ static void generate_opcode_app (sexp app, sexp context) { } /* emit optional folding of operator */ - if (num_args > 2) { - if (sexp_opcode_class(op) == OPC_ARITHMETIC - || sexp_opcode_class(op) == OPC_ARITHMETIC_INV) { - for (i=num_args-2; i>0; i--) - emit(sexp_opcode_code(op), context); - } else if (sexp_opcode_class(op) == OPC_ARITHMETIC_CMP) { - /* XXXX handle folding of comparisons */ - } - } + if ((num_args > 2) + && (sexp_opcode_class(op) == OPC_ARITHMETIC + || sexp_opcode_class(op) == OPC_ARITHMETIC_INV)) + for (i=num_args-2; i>0; i--) + emit(sexp_opcode_code(op), context); sexp_context_depth(context) -= (num_args-1); } @@ -770,6 +724,13 @@ static void generate_general_app (sexp app, sexp context) { sexp_context_depth(context) -= len; } +static void generate_app (sexp app, sexp context) { + if (sexp_opcodep(sexp_car(app))) + generate_opcode_app(app, context); + else + generate_general_app(app, context); +} + static void generate_lambda (sexp lambda, sexp context) { sexp fv, ls, ctx, flags, bc, len, ref, vec, prev_lambda, prev_fv; sexp_uint_t k; @@ -829,6 +790,38 @@ static void generate_lambda (sexp lambda, sexp context) { } } +static void generate (sexp x, sexp context) { + if (sexp_pointerp(x)) { + switch (sexp_pointer_tag(x)) { + case SEXP_PAIR: + generate_app(x, context); + break; + case SEXP_LAMBDA: + generate_lambda(x, context); + break; + case SEXP_CND: + generate_cnd(x, context); + break; + case SEXP_REF: + generate_ref(x, context, 1); + break; + case SEXP_SET: + generate_set(x, context); + break; + case SEXP_SEQ: + generate_seq(sexp_seq_ls(x), context); + break; + case SEXP_LIT: + generate_lit(sexp_lit_value(x), context); + break; + default: + generate_lit(x, context); + } + } else { + generate_lit(x, context); + } +} + static sexp insert_free_var (sexp x, sexp fv) { sexp name=sexp_ref_name(x), loc=sexp_ref_loc(x), ls; for (ls=fv; sexp_pairp(ls); ls=sexp_cdr(ls)) @@ -1186,6 +1179,10 @@ sexp vm(sexp bc, sexp cp, sexp context, sexp* stack, sexp_sint_t top) { _ARG2 = sexp_make_vector(_ARG1, _ARG2); top--; break; + case OP_AND: + _ARG2 = sexp_make_boolean((_ARG1 != SEXP_FALSE) && (_ARG2 != SEXP_FALSE)); + top--; + break; case OP_EOFP: _ARG1 = sexp_make_boolean(_ARG1 == SEXP_EOF); break; case OP_NULLP: @@ -1400,6 +1397,11 @@ sexp vm(sexp bc, sexp cp, sexp context, sexp* stack, sexp_sint_t top) { _ARG2 = SEXP_UNDEF; top--; break; + } else if (sexp_charp(_ARG1)) { + sexp_write_char(sexp_unbox_character(_ARG1), _ARG2); + _ARG2 = SEXP_UNDEF; + top--; + break; } /* ... FALLTHROUGH ... */ case OP_WRITE: @@ -1428,6 +1430,11 @@ sexp vm(sexp bc, sexp cp, sexp context, sexp* stack, sexp_sint_t top) { i = sexp_read_char(_ARG1); _ARG1 = (i == EOF) ? SEXP_EOF : sexp_make_character(i); break; + case OP_PEEK_CHAR: + i = sexp_read_char(_ARG1); + sexp_push_char(i, _ARG1); + _ARG1 = (i == EOF) ? SEXP_EOF : sexp_make_character(i); + break; case OP_RET: i = sexp_unbox_integer(stack[fp]); stack[fp-i] = _ARG1; diff --git a/eval.h b/eval.h index 8a7a791b..19c6e01a 100644 --- a/eval.h +++ b/eval.h @@ -82,6 +82,7 @@ enum opcode_names { OP_STRING_LENGTH, OP_MAKE_PROCEDURE, OP_MAKE_VECTOR, + OP_AND, OP_NULLP, OP_INTEGERP, OP_SYMBOLP, @@ -118,6 +119,7 @@ enum opcode_names { OP_FLUSH_OUTPUT, OP_READ, OP_READ_CHAR, + OP_PEEK_CHAR, OP_RET, OP_DONE, }; diff --git a/init.scm b/init.scm index 78332557..a06c5acc 100644 --- a/init.scm +++ b/init.scm @@ -3,8 +3,6 @@ ;; remainder modulo ;; number->string string->number ;; symbol->string string->symbol -;; char-alphabetic? char-numeric? char-whitespace? -;; char-upper-case? char-lower-case? ;; make-string ;; string=? string-ci=? string? ;; string<=? string>=? string-ci? string-ci<=? string-ci>=? @@ -12,7 +10,6 @@ ;; values call-with-values dynamic-wind ;; call-with-input-file call-with-output-file ;; with-input-from-file with-output-to-file -;; peek-char char-ready? ;; provide c[ad]{2,4}r @@ -298,6 +295,15 @@ ;; char utils +(define (char-alphabetic? ch) (<= 65 (char->integer (char-upcase ch)) 90)) +(define (char-numeric? ch) (<= 48 (char->integer ch) 57)) +(define (char-whitespace? ch) + (if (eq? ch #\space) + #t + (if (eq? ch #\tab) #t (if (eq? ch #\newline) #t (eq? ch #\return))))) +(define (char-upper-case? ch) (<= 65 (char->integer ch) 90)) +(define (char-lower-case? ch) (<= 97 (char->integer ch) 122)) + (define (char=? a b) (= (char->integer a) (char->integer b))) (define (charinteger a) (char->integer b))) (define (char>? a b) (> (char->integer a) (char->integer b))) @@ -400,7 +406,10 @@ (define (vector . args) (list->vector args)) -;; miscellaneous +;; I/O utilities + +(define (char-ready? . o) + (not (eof-object? (peek-char (if (pair? o) (car o) (current-input-port)))))) (define (load file) (%load file (interaction-environment))) diff --git a/opcodes.c b/opcodes.c index 813c4d37..c8fb6d66 100644 --- a/opcodes.c +++ b/opcodes.c @@ -62,6 +62,7 @@ _OP(OPC_IO, OP_NEWLINE, 0, 3, 0, SEXP_OPORT, 0, "newline", (sexp)"*current-outpu _OP(OPC_IO, OP_FLUSH_OUTPUT, 0, 3, 0, SEXP_OPORT, 0, "flush-output", (sexp)"*current-output-port*", NULL), _OP(OPC_IO, OP_READ, 0, 3, 0, SEXP_IPORT, 0, "read", (sexp)"*current-input-port*", NULL), _OP(OPC_IO, OP_READ_CHAR, 0, 3, 0, SEXP_IPORT, 0, "read-char", (sexp)"*current-input-port*", NULL), +_OP(OPC_IO, OP_PEEK_CHAR, 0, 3, 0, SEXP_IPORT, 0, "peek-char", (sexp)"*current-input-port*", NULL), _OP(OPC_GENERIC, OP_EVAL, 1, 3, 0, 0, 0, "eval", (sexp)"*interaction-environment*", NULL), _FN2(0, 0, "equal?", sexp_equalp), _FN1(0, "list?", sexp_listp), diff --git a/sexp.c b/sexp.c index fd55200a..702afcc4 100644 --- a/sexp.c +++ b/sexp.c @@ -573,6 +573,10 @@ void sexp_write (sexp obj, sexp out) { sexp_write_string("#\\space", out); else if (obj == sexp_make_character('\n')) sexp_write_string("#\\newline", out); + else if (obj == sexp_make_character('\r')) + sexp_write_string("#\\return", out); + else if (obj == sexp_make_character('\t')) + sexp_write_string("#\\tab", out); else if ((33 <= sexp_unbox_character(obj)) && (sexp_unbox_character(obj) < 127)) sexp_printf(out, "#\\%c", sexp_unbox_character(obj)); From 2e55517108b7bb15aa0a0d9eda4d97d9151d5201 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 2 Apr 2009 18:35:08 +0900 Subject: [PATCH 080/154] string utilities --- debug.c | 3 +- eval.c | 121 ++++++++++++++++++++++++++++++++++++++++++++++-------- eval.h | 8 ++-- init.scm | 40 +++++++++++++++--- opcodes.c | 13 ++++-- sexp.c | 29 ++++++++----- sexp.h | 8 ++-- 7 files changed, 175 insertions(+), 47 deletions(-) diff --git a/debug.c b/debug.c index 6bdc8b01..89923926 100644 --- a/debug.c +++ b/debug.c @@ -10,7 +10,8 @@ static const char* reverse_opcode_names[] = "STRING-SET", "STRING-LENGTH", "MAKE-PROCEDURE", "MAKE-VECTOR", "AND", "NULL?", "FIXNUM?", "SYMBOL?", "CHAR?", "EOF?", "TYPEP", "CAR", "CDR", "SET-CAR", "SET-CDR", "CONS", "ADD", "SUB", - "MUL", "DIV", "QUOT", "MOD", "NEG", "INV", "LT", "LE", "EQN", "EQ", + "MUL", "DIV", "QUOTIENT", "REMAINDER", "NEGATIVE", "INVERSE", + "LT", "LE", "EQN", "EQ", "EXACT->INEXACT", "INEXACT->EXACT", "CHAR->INTEGER", "INTEGER->CHAR", "CHAR-UPCASE", "CHAR-DOWNCASE", "DISPLAY", "WRITE", "WRITE-CHAR", diff --git a/eval.c b/eval.c index dd242cd6..b0fae803 100644 --- a/eval.c +++ b/eval.c @@ -285,7 +285,7 @@ static sexp sexp_identifier_eq (sexp e1, sexp id1, sexp e2, sexp id2) { static sexp sexp_compile_error(char *message, sexp irritants) { return sexp_make_exception(the_compile_error_symbol, - sexp_make_string(message), + sexp_c_string(message), irritants, SEXP_FALSE, SEXP_FALSE); } @@ -1280,21 +1280,26 @@ sexp vm(sexp bc, sexp cp, sexp context, sexp* stack, sexp_sint_t top) { else sexp_raise("/: not a number", sexp_list2(_ARG1, _ARG2)); top--; break; - case OP_QUOT: + case OP_QUOTIENT: if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) { + if (_ARG1 == sexp_make_integer(0)) + sexp_raise("divide by zero", SEXP_NULL); _ARG2 = sexp_fx_div(_ARG1, _ARG2); top--; } - else sexp_raise("quotient: not a number", sexp_list2(_ARG1, _ARG2)); + else sexp_raise("quotient: not an integer", sexp_list2(_ARG1, _ARG2)); break; - case OP_MOD: + case OP_REMAINDER: if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) { - _ARG2 = sexp_fx_mod(_ARG1, _ARG2); + if (_ARG1 == sexp_make_integer(0)) + sexp_raise("divide by zero", SEXP_NULL); + tmp1 = sexp_fx_rem(_ARG1, _ARG2); top--; + _ARG1 = tmp1; } - else sexp_raise("modulo: not a number", sexp_list2(_ARG1, _ARG2)); + else sexp_raise("remainder: not an integer", sexp_list2(_ARG1, _ARG2)); break; - case OP_NEG: + case OP_NEGATIVE: if (sexp_integerp(_ARG1)) _ARG1 = sexp_make_integer(-sexp_unbox_integer(_ARG1)); #if USE_FLONUMS @@ -1303,7 +1308,7 @@ sexp vm(sexp bc, sexp cp, sexp context, sexp* stack, sexp_sint_t top) { #endif else sexp_raise("-: not a number", sexp_list1(_ARG1)); break; - case OP_INV: + case OP_INVERSE: if (sexp_integerp(_ARG1)) _ARG1 = sexp_make_flonum(1/(double)sexp_unbox_integer(_ARG1)); #if USE_FLONUMS @@ -1483,14 +1488,21 @@ sexp sexp_load (sexp source, sexp env) { return res; } -#if USE_MATH - -static sexp sexp_math_exception (char *message, sexp obj) { +static sexp sexp_type_exception (char *message, sexp obj) { return sexp_make_exception(sexp_intern("type-error"), - sexp_make_string(message), + sexp_c_string(message), sexp_list1(obj), SEXP_FALSE, SEXP_FALSE); } +static sexp sexp_range_exception (sexp obj, sexp start, sexp end) { + return sexp_make_exception(sexp_intern("range-error"), + sexp_c_string("bad index range"), + sexp_list3(obj, start, end), + SEXP_FALSE, SEXP_FALSE); +} + +#if USE_MATH + #define define_math_op(name, cname) \ static sexp name (sexp z) { \ double d; \ @@ -1499,7 +1511,7 @@ static sexp sexp_math_exception (char *message, sexp obj) { else if (sexp_integerp(z)) \ d = (double)sexp_unbox_integer(z); \ else \ - return sexp_math_exception("not a number", z); \ + return sexp_type_exception("not a number", z); \ return sexp_make_flonum(cname(d)); \ } @@ -1528,7 +1540,7 @@ static sexp sexp_expt (sexp x, sexp e) { x1 = sexp_flonum_value(x); #endif else - return sexp_math_exception("not a number", x); + return sexp_type_exception("not a number", x); if (sexp_integerp(e)) e1 = (double)sexp_unbox_integer(e); #if USE_FLONUMS @@ -1536,7 +1548,7 @@ static sexp sexp_expt (sexp x, sexp e) { e1 = sexp_flonum_value(e); #endif else - return sexp_math_exception("not a number", e); + return sexp_type_exception("not a number", e); res = pow(x1, e1); #if USE_FLONUMS if ((res > SEXP_MAX_INT) || sexp_flonump(x) || sexp_flonump(e)) @@ -1545,6 +1557,79 @@ static sexp sexp_expt (sexp x, sexp e) { return sexp_make_integer((sexp_sint_t)round(res)); } +static sexp sexp_substring (sexp str, sexp start, sexp end) { + sexp res; + if (! sexp_stringp(str)) + return sexp_type_exception("not a string", str); + if (! sexp_integerp(start)) + return sexp_type_exception("not a number", start); + if (end == SEXP_FALSE) + end = sexp_make_integer(sexp_string_length(str)); + if (! sexp_integerp(end)) + return sexp_type_exception("not a number", end); + if ((sexp_unbox_integer(start) < 0) + || (sexp_unbox_integer(start) > sexp_string_length(str)) + || (sexp_unbox_integer(end) < 0) + || (sexp_unbox_integer(end) > sexp_string_length(str)) + || (end < start)) + return sexp_range_exception(str, start, end); + res = sexp_make_string(sexp_fx_sub(end, start), + SEXP_UNDEF); + memcpy(sexp_string_data(res), + sexp_string_data(str)+sexp_unbox_integer(start), + sexp_string_length(res)); + return res; +} + +static sexp sexp_string_concatenate (sexp str_ls) { + sexp res, ls; + sexp_uint_t len=0; + char *p; + for (ls=str_ls; sexp_pairp(ls); ls=sexp_cdr(ls)) + if (! sexp_stringp(sexp_car(ls))) + return sexp_type_exception("not a string", sexp_car(ls)); + else + len += sexp_string_length(sexp_car(ls)); + res = sexp_make_string(sexp_make_integer(len), SEXP_UNDEF); + p = sexp_string_data(res); + for (ls=str_ls; sexp_pairp(ls); ls=sexp_cdr(ls)) { + len = sexp_string_length(sexp_car(ls)); + memcpy(p, sexp_string_data(sexp_car(ls)), len); + p += len; + } + return res; +} + +static sexp sexp_string_cmp (sexp str1, sexp str2) { + sexp_sint_t len1, len2, len, diff; + if (! sexp_stringp(str1)) + return sexp_type_exception("not a string", str1); + if (! sexp_stringp(str2)) + return sexp_type_exception("not a string", str2); + len1 = sexp_string_length(str1); + len2 = sexp_string_length(str2); + len = ((len1string string->number ;; symbol->string string->symbol -;; make-string -;; string=? string-ci=? string? -;; string<=? string>=? string-ci? string-ci<=? string-ci>=? -;; substring string-append string-copy -;; values call-with-values dynamic-wind ;; call-with-input-file call-with-output-file ;; with-input-from-file with-output-to-file @@ -341,6 +335,20 @@ (if (>= i 0) (begin (string-set! str i ch) (lp (- i 1)))))) (define (string . args) (list->string args)) +(define (string-append . args) (string-concatenate args)) +(define (string-copy s) (substring s 0 (string-length s))) + +(define (string=? s1 s2) (eq? (string-cmp s1 s2) 0)) +(define (string? s1 s2) (> (string-cmp s1 s2) 0)) +(define (string>=? s1 s2) (>= (string-cmp s1 s2) 0)) + +(define (string-ci=? s1 s2) (eq? (string-cmp-ci s1 s2) 0)) +(define (string-ci? s1 s2) (> (string-cmp-ci s1 s2) 0)) +(define (string-ci>=? s1 s2) (>= (string-cmp-ci s1 s2) 0)) ;; math utils @@ -360,6 +368,12 @@ (define (abs x) (if (< x 0) (- x) x)) +(define (modulo a b) + (let ((res (remainder a b))) + (if (< b 0) + (if (< res 0) res (- res b)) + (if (> res 0) res (+ res b))))) + (define (gcd a b) (if (= b 0) a @@ -413,3 +427,17 @@ (define (load file) (%load file (interaction-environment))) +;; values + +(define *values-tag* (list 'values)) + +(define (values . ls) + (if (and (pair? ls) (null? (cdr ls))) + (car ls) + (cons *values-tag* ls))) + +(define (call-with-values producer consumer) + (let ((res (producer))) + (if (and (pair? res) (eq? *values-tag* (car res))) + (apply consumer (cdr res)) + (consumer res)))) diff --git a/opcodes.c b/opcodes.c index c8fb6d66..e9a3ca74 100644 --- a/opcodes.c +++ b/opcodes.c @@ -27,10 +27,10 @@ _OP(OPC_GENERIC, OP_CHAR_UPCASE, 1, 0, SEXP_CHAR, 0, 0, "char-upcase", NULL, NUL _OP(OPC_GENERIC, OP_CHAR_DOWNCASE, 1, 0, SEXP_CHAR, 0, 0, "char-downcase", NULL, NULL), _OP(OPC_ARITHMETIC, OP_ADD, 0, 1, SEXP_FIXNUM, 0, 0, "+", NULL, NULL), _OP(OPC_ARITHMETIC, OP_MUL, 0, 1, SEXP_FIXNUM, 0, 0, "*", NULL, NULL), -_OP(OPC_ARITHMETIC_INV, OP_SUB, 0, 1, SEXP_FIXNUM, 0, OP_NEG, "-", NULL, NULL), -_OP(OPC_ARITHMETIC_INV, OP_DIV, 0, 1, SEXP_FIXNUM, 0, OP_INV, "/", NULL, NULL), -_OP(OPC_ARITHMETIC, OP_QUOT, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, 0, "quotient", NULL, NULL), -_OP(OPC_ARITHMETIC, OP_MOD, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, 0, "modulo", NULL, NULL), +_OP(OPC_ARITHMETIC_INV, OP_SUB, 0, 1, SEXP_FIXNUM, 0, OP_NEGATIVE, "-", NULL, NULL), +_OP(OPC_ARITHMETIC_INV, OP_DIV, 0, 1, SEXP_FIXNUM, 0, OP_INVERSE, "/", NULL, NULL), +_OP(OPC_ARITHMETIC, OP_QUOTIENT, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, 0, "quotient", NULL, NULL), +_OP(OPC_ARITHMETIC, OP_REMAINDER, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, 0, "remainder", NULL, NULL), _OP(OPC_ARITHMETIC_CMP, OP_LT, 0, 1, SEXP_FIXNUM, 0, 0, "<", NULL, NULL), _OP(OPC_ARITHMETIC_CMP, OP_LE, 0, 1, SEXP_FIXNUM, 0, 0, "<=", NULL, NULL), _OP(OPC_ARITHMETIC_CMP, OP_LT, 0, 1, SEXP_FIXNUM, 0, 1, ">", NULL, NULL), @@ -78,6 +78,11 @@ _FN1(SEXP_OPORT, "close-output-port", sexp_close_port), _FN1(SEXP_FIXNUM, "null-environment", sexp_make_null_env), _FN1(SEXP_FIXNUM, "scheme-report-environment", sexp_make_standard_env), _FN2(0, SEXP_ENV, "%load", sexp_load), +_FN2(SEXP_FIXNUM, SEXP_CHAR, "make-string", sexp_make_string), +_FN2(SEXP_STRING, SEXP_STRING, "string-cmp", sexp_string_cmp), +_FN2(SEXP_STRING, SEXP_STRING, "string-cmp-ci", sexp_string_cmp_ci), +_FN3(SEXP_STRING, SEXP_FIXNUM, "substring", sexp_substring), +_FN1(SEXP_PAIR, "string-concatenate", sexp_string_concatenate), #if USE_MATH _FN1(0, "exp", sexp_exp), _FN1(0, "log", sexp_log), diff --git a/sexp.c b/sexp.c index 702afcc4..8cb49a33 100644 --- a/sexp.c +++ b/sexp.c @@ -139,9 +139,9 @@ sexp sexp_print_exception (sexp exn, sexp out) { static sexp sexp_read_error (char *message, sexp irritants, sexp port) { sexp name = (sexp_port_name(port) - ? sexp_make_string(sexp_port_name(port)) : SEXP_FALSE); + ? sexp_c_string(sexp_port_name(port)) : SEXP_FALSE); return sexp_make_exception(the_read_error_symbol, - sexp_make_string(message), + sexp_c_string(message), irritants, name, sexp_make_integer(sexp_port_line(port))); @@ -269,13 +269,22 @@ sexp sexp_make_flonum(double f) { return x; } -sexp sexp_make_string(char *str) { +sexp sexp_make_string(sexp len, sexp ch) { sexp s = sexp_alloc_type(string, SEXP_STRING); + sexp_uint_t clen = sexp_unbox_integer(len); + char *cstr = sexp_alloc(clen+1); + if (sexp_charp(ch)) + memset(cstr, sexp_unbox_character(ch), clen); + cstr[clen] = '\0'; + sexp_string_length(s) = clen; + sexp_string_data(s) = cstr; + return s; +} + +sexp sexp_c_string(char *str) { 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; + sexp s = sexp_make_string(sexp_make_integer(len), SEXP_UNDEF); + memcpy(sexp_string_data(s), str, len); return s; } @@ -754,7 +763,7 @@ sexp sexp_read_raw (sexp in) { break; case '"': str = sexp_read_string(in); - res = sexp_make_string(str); + res = sexp_c_string(str); sexp_free(str); break; case '(': @@ -847,7 +856,7 @@ sexp sexp_read_raw (sexp in) { res = sexp_make_character('\t'); else { res = sexp_read_error("unknown character name", - sexp_list1(sexp_make_string(str)), + sexp_list1(sexp_c_string(str)), in); } } @@ -928,7 +937,7 @@ sexp sexp_read (sexp in) { } sexp sexp_read_from_string(char *str) { - sexp s = sexp_make_string(str); + sexp s = sexp_c_string(str); sexp in = sexp_make_input_string_port(s); sexp res = sexp_read(in); sexp_deep_free(s); diff --git a/sexp.h b/sexp.h index 4d46b3c6..7db6b806 100644 --- a/sexp.h +++ b/sexp.h @@ -344,7 +344,8 @@ struct sexp_struct { #define sexp_fx_sub(a, b) ((sexp)(((sexp_sint_t)a)-((sexp_sint_t)b)+SEXP_FIXNUM_TAG)) #define sexp_fx_mul(a, b) ((sexp)((((((sexp_sint_t)a)-SEXP_FIXNUM_TAG)*(((sexp_sint_t)b)>>SEXP_FIXNUM_BITS))+SEXP_FIXNUM_TAG))) #define sexp_fx_div(a, b) (sexp_make_integer(sexp_unbox_integer(a) / sexp_unbox_integer(b))) -#define sexp_fx_mod(a, b) (sexp_make_integer(sexp_unbox_integer(a) % sexp_unbox_integer(b))) +#define sexp_fx_rem(a, b) (sexp_make_integer(sexp_unbox_integer(a) % sexp_unbox_integer(b))) +#define sexp_fx_sign(a) (-((sexp_sint_t)(a) < 0)) /* -1 or 0 */ #define sexp_fp_add(a, b) (sexp_make_flonum(sexp_flonum_value(a) + sexp_flonum_value(b))) #define sexp_fp_sub(a, b) (sexp_make_flonum(sexp_flonum_value(a) - sexp_flonum_value(b))) @@ -368,7 +369,6 @@ struct sexp_struct { #define sexp_cadr(x) (sexp_car(sexp_cdr(x))) #define sexp_cdar(x) (sexp_cdr(sexp_car(x))) #define sexp_cddr(x) (sexp_cdr(sexp_cdr(x))) - #define sexp_caaar(x) (sexp_car(sexp_caar(x))) #define sexp_caadr(x) (sexp_car(sexp_cadr(x))) #define sexp_cadar(x) (sexp_car(sexp_cdar(x))) @@ -377,7 +377,6 @@ struct sexp_struct { #define sexp_cdadr(x) (sexp_cdr(sexp_cadr(x))) #define sexp_cddar(x) (sexp_cdr(sexp_cdar(x))) #define sexp_cdddr(x) (sexp_cdr(sexp_cddr(x))) - #define sexp_cadddr(x) (sexp_cadr(sexp_cddr(x))) #define sexp_cddddr(x) (sexp_cddr(sexp_cddr(x))) @@ -417,7 +416,8 @@ sexp sexp_append(sexp a, sexp b); sexp sexp_memq(sexp x, sexp ls); sexp sexp_assq(sexp x, sexp ls); sexp sexp_length(sexp ls); -sexp sexp_make_string(char *str); +sexp sexp_c_string(char *str); +sexp sexp_make_string(sexp len, sexp ch); sexp sexp_make_flonum(double f); int sexp_string_hash(char *str, int acc); sexp sexp_intern(char *str); From 7130f38e767e288137a068c038081e52171ed07b Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 2 Apr 2009 20:03:46 +0900 Subject: [PATCH 081/154] string-ports --- debug.c | 12 +++-- eval.c | 49 ++----------------- init.scm | 23 ++++++++- opcodes.c | 24 ++++++--- sexp.c | 143 +++++++++++++++++++++++++++++++++++++++++++----------- sexp.h | 22 ++------- 6 files changed, 171 insertions(+), 102 deletions(-) diff --git a/debug.c b/debug.c index 89923926..4ff6d2cd 100644 --- a/debug.c +++ b/debug.c @@ -18,8 +18,11 @@ static const char* reverse_opcode_names[] = "NEWLINE", "FLUSH-OUTPUT", "READ", "READ-CHAR", "PEEK-CHAR", "RET", "DONE", }; -void disasm (sexp bc, sexp out) { - unsigned char *ip=sexp_bytecode_data(bc), opcode; +static sexp sexp_disasm (sexp bc, sexp out) { + unsigned char *ip, opcode; + if (sexp_procedurep(bc)) + bc = sexp_procedure_code(bc); + ip = sexp_bytecode_data(bc); loop: opcode = *ip++; if (opcode*sizeof(char*) < sizeof(reverse_opcode_names)) { @@ -52,9 +55,10 @@ void disasm (sexp bc, sexp out) { sexp_write_char('\n', out); if (ip - sexp_bytecode_data(bc) < sexp_bytecode_length(bc)) goto loop; + return SEXP_UNDEF; } -void print_bytecode (sexp bc) { +static void print_bytecode (sexp bc) { int i; unsigned char *data = sexp_bytecode_data(bc); fprintf(stderr, "bytecode @ %p, data @ %p, length = %lu\n", @@ -79,7 +83,7 @@ void print_bytecode (sexp bc) { } } -void print_stack (sexp *stack, int top, int fp, sexp out) { +static void print_stack (sexp *stack, int top, int fp, sexp out) { int i; for (i=0; i sexp_string_length(str)) - || (sexp_unbox_integer(end) < 0) - || (sexp_unbox_integer(end) > sexp_string_length(str)) - || (end < start)) - return sexp_range_exception(str, start, end); - res = sexp_make_string(sexp_fx_sub(end, start), - SEXP_UNDEF); - memcpy(sexp_string_data(res), - sexp_string_data(str)+sexp_unbox_integer(start), - sexp_string_length(res)); - return res; -} - static sexp sexp_string_concatenate (sexp str_ls) { sexp res, ls; sexp_uint_t len=0; diff --git a/init.scm b/init.scm index 530a0ae1..eb78c704 100644 --- a/init.scm +++ b/init.scm @@ -2,7 +2,6 @@ ;; let-syntax letrec-syntax syntax-rules ;; number->string string->number ;; symbol->string string->symbol -;; call-with-input-file call-with-output-file ;; with-input-from-file with-output-to-file ;; provide c[ad]{2,4}r @@ -420,13 +419,33 @@ (define (vector . args) (list->vector args)) -;; I/O utilities +;; I/O utils (define (char-ready? . o) (not (eof-object? (peek-char (if (pair? o) (car o) (current-input-port)))))) (define (load file) (%load file (interaction-environment))) +(define (call-with-input-string str proc) + (proc (open-input-string str))) + +(define (call-with-output-string proc) + (let ((out (open-output-string))) + (proc out) + (get-output-string out))) + +(define (call-with-input-file file proc) + (let* ((in (open-input-file file)) + (res (proc in))) + (close-input-port in) + res)) + +(define (call-with-output-file file proc) + (let* ((out (open-output-file file)) + (res (proc in))) + (close-output-port in) + res)) + ;; values (define *values-tag* (list 'values)) diff --git a/opcodes.c b/opcodes.c index e9a3ca74..f4f326b4 100644 --- a/opcodes.c +++ b/opcodes.c @@ -83,6 +83,14 @@ _FN2(SEXP_STRING, SEXP_STRING, "string-cmp", sexp_string_cmp), _FN2(SEXP_STRING, SEXP_STRING, "string-cmp-ci", sexp_string_cmp_ci), _FN3(SEXP_STRING, SEXP_FIXNUM, "substring", sexp_substring), _FN1(SEXP_PAIR, "string-concatenate", sexp_string_concatenate), +_FN2(0, SEXP_PAIR, "memq", sexp_memq), +_FN2(0, SEXP_PAIR, "assq", sexp_assq), +_FN3(SEXP_ENV, SEXP_PAIR, "make-syntactic-closure", sexp_make_synclo), +_PARAM("current-input-port", (sexp)"*current-input-port*", SEXP_IPORT), +_PARAM("current-output-port", (sexp)"*current-output-port*", SEXP_OPORT), +_PARAM("current-error-port", (sexp)"*current-error-port*", SEXP_OPORT), +_PARAM("current-error-handler", (sexp)"*current-error-handler*", SEXP_PROCEDURE), +_PARAM("interaction-environment", (sexp)"*interaction-environment*", SEXP_ENV), #if USE_MATH _FN1(0, "exp", sexp_exp), _FN1(0, "log", sexp_log), @@ -99,13 +107,13 @@ _FN1(0, "floor", sexp_floor), _FN1(0, "ceiling", sexp_ceiling), _FN2(0, 0, "expt", sexp_expt), #endif -_FN2(0, SEXP_PAIR, "memq", sexp_memq), -_FN2(0, SEXP_PAIR, "assq", sexp_assq), -_FN3(SEXP_ENV, SEXP_PAIR, "make-syntactic-closure", sexp_make_synclo), -_PARAM("current-input-port", (sexp)"*current-input-port*", SEXP_IPORT), -_PARAM("current-output-port", (sexp)"*current-output-port*", SEXP_OPORT), -_PARAM("current-error-port", (sexp)"*current-error-port*", SEXP_OPORT), -_PARAM("current-error-handler", (sexp)"*current-error-handler*", SEXP_PROCEDURE), -_PARAM("interaction-environment", (sexp)"*interaction-environment*", SEXP_ENV), +#if USE_STRING_STREAMS +_FN0("open-output-string", sexp_make_output_string_port), +_FN1(SEXP_STRING, "open-input-string", sexp_make_input_string_port), +_FN1(SEXP_OPORT, "get-output-string", sexp_get_output_string), +#endif +#if USE_DEBUG +_FN2(SEXP_PROCEDURE, SEXP_OPORT, "disasm", sexp_disasm), +#endif }; diff --git a/sexp.c b/sexp.c index 8cb49a33..936d70e3 100644 --- a/sexp.c +++ b/sexp.c @@ -102,6 +102,19 @@ sexp sexp_make_exception (sexp kind, sexp message, sexp irritants, return exn; } +sexp sexp_type_exception (char *message, sexp obj) { + return sexp_make_exception(sexp_intern("type-error"), + sexp_c_string(message), + sexp_list1(obj), SEXP_FALSE, SEXP_FALSE); +} + +sexp sexp_range_exception (sexp obj, sexp start, sexp end) { + return sexp_make_exception(sexp_intern("range-error"), + sexp_c_string("bad index range"), + sexp_list3(obj, start, end), + SEXP_FALSE, SEXP_FALSE); +} + sexp sexp_print_exception (sexp exn, sexp out) { sexp ls; sexp_write_string("ERROR", out); @@ -288,6 +301,30 @@ sexp sexp_c_string(char *str) { return s; } +sexp sexp_substring (sexp str, sexp start, sexp end) { + sexp res; + if (! sexp_stringp(str)) + return sexp_type_exception("not a string", str); + if (! sexp_integerp(start)) + return sexp_type_exception("not a number", start); + if (end == SEXP_FALSE) + end = sexp_make_integer(sexp_string_length(str)); + if (! sexp_integerp(end)) + return sexp_type_exception("not a number", end); + if ((sexp_unbox_integer(start) < 0) + || (sexp_unbox_integer(start) > sexp_string_length(str)) + || (sexp_unbox_integer(end) < 0) + || (sexp_unbox_integer(end) > sexp_string_length(str)) + || (end < start)) + return sexp_range_exception(str, start, end); + res = sexp_make_string(sexp_fx_sub(end, start), + SEXP_UNDEF); + memcpy(sexp_string_data(res), + sexp_string_data(str)+sexp_unbox_integer(start), + sexp_string_length(res)); + return res; +} + #define FNV_PRIME 16777619 #define FNV_OFFSET_BASIS 2166136261uL @@ -392,50 +429,95 @@ sexp sexp_vector(int count, ...) { #if USE_STRING_STREAMS +#define SEXP_INIT_STRING_PORT_SIZE 128 + +#if SEXP_BSD + +#define sexp_stream_buf(vec) sexp_vector_ref((sexp)vec, sexp_make_integer(0)) +#define sexp_stream_size(vec) sexp_vector_ref((sexp)vec, sexp_make_integer(1)) +#define sexp_stream_pos(vec) sexp_vector_ref((sexp)vec, sexp_make_integer(2)) + 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)); + sexp_uint_t len = sexp_unbox_integer(sexp_stream_size(vec)); + sexp_uint_t pos = sexp_unbox_integer(sexp_stream_pos(vec)); 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); + memcpy(dst, sexp_string_data(sexp_stream_buf(vec))+pos, n); + sexp_vector_set((sexp) vec, sexp_make_integer(2), sexp_make_integer(n)); return n; } int sstream_write(void *vec, const char *src, int n) { + sexp_uint_t len, pos, newpos; + sexp newbuf; + len = sexp_unbox_integer(sexp_stream_size(vec)); + pos = sexp_unbox_integer(sexp_stream_pos(vec)); + newpos = pos+n; + if (newpos > len) { + newbuf = sexp_make_string(sexp_make_integer(len*2), SEXP_UNDEF); + memcpy(sexp_string_data(newbuf), + sexp_string_data(sexp_stream_buf(vec)), + pos); + sexp_vector_set((sexp)vec, sexp_make_integer(0), newbuf); + sexp_vector_set((sexp)vec, sexp_make_integer(1), sexp_make_integer(len*2)); + } + memcpy(sexp_string_data(sexp_stream_buf(vec))+pos, src, n); + sexp_vector_set((sexp)vec, sexp_make_integer(2), sexp_make_integer(newpos)); return n; } off_t sstream_seek(void *vec, off_t offset, int whence) { - int pos; + sexp_sint_t pos; if (whence == SEEK_SET) { pos = offset; } else if (whence == SEEK_CUR) { - pos = (int) sexp_vector_ref((sexp) vec, sexp_make_integer(2)) + offset; + pos = sexp_unbox_integer(sexp_stream_pos(vec)) + offset; } else { /* SEEK_END */ - pos = (int) sexp_vector_ref((sexp) vec, sexp_make_integer(1)) + offset; + pos = sexp_unbox_integer(sexp_stream_size(vec)) + offset; } - sexp_vector_set((sexp) vec, sexp_make_integer(2), (sexp)pos); + sexp_vector_set((sexp)vec, sexp_make_integer(2), sexp_make_integer(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; + sexp res, cookie; + cookie = sexp_vector(3, str, sexp_make_integer(sexp_string_length(str)), + sexp_make_integer(0)); + in = funopen(cookie, &sstream_read, NULL, &sstream_seek, NULL); + res = sexp_make_input_port(in); + sexp_port_cookie(res) = cookie; + return res; } +sexp sexp_make_output_string_port() { + FILE *out; + sexp res, size, cookie; + size = sexp_make_integer(SEXP_INIT_STRING_PORT_SIZE); + cookie = sexp_vector(3, sexp_make_string(size, SEXP_UNDEF), + size, sexp_make_integer(0)); + out = funopen(cookie, NULL, &sstream_write, &sstream_seek, NULL); + res = sexp_make_output_port(out); + sexp_port_cookie(res) = cookie; + return res; +} + +sexp sexp_get_output_string(sexp port) { + sexp cookie = sexp_port_cookie(port); + fflush(sexp_port_stream(port)); + return sexp_substring(sexp_stream_buf(cookie), + sexp_make_integer(0), + sexp_stream_pos(cookie)); +} + +#else + 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 #endif @@ -560,19 +642,26 @@ void sexp_write (sexp obj, sexp out) { 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] == '\\') + switch (str[0]) { + case '\\': sexp_write_string("\\\\", out); break; + case '"': sexp_write_string("\\\"", out); break; + case '\n': sexp_write_string("\\n", out); break; + case '\r': sexp_write_string("\\r", out); break; + case '\t': sexp_write_string("\\t", out); break; + default: sexp_write_char(str[0], out); + } + } + sexp_write_char('"', out); + break; + case SEXP_SYMBOL: + i = sexp_symbol_length(obj); + str = sexp_symbol_data(obj); + for ( ; i>0; str++, i--) { + if ((str[0] == '\\') || is_separator(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)) { diff --git a/sexp.h b/sexp.h index 7db6b806..ae4835b2 100644 --- a/sexp.h +++ b/sexp.h @@ -102,6 +102,7 @@ struct sexp_struct { FILE *stream; char *name; sexp_uint_t line; + sexp cookie; } port; struct { sexp kind, message, irritants, file, line; @@ -263,6 +264,7 @@ struct sexp_struct { #define sexp_port_stream(p) ((p)->value.port.stream) #define sexp_port_name(p) ((p)->value.port.name) #define sexp_port_line(p) ((p)->value.port.line) +#define sexp_port_cookie(p) ((p)->value.port.cookie) #define sexp_exception_kind(p) ((p)->value.exception.kind) #define sexp_exception_message(p) ((p)->value.exception.message) @@ -382,29 +384,12 @@ struct sexp_struct { /***************************** general API ****************************/ -#if USE_STRING_STREAMS -#if SEXP_BSD -#define fmemopen(str, len, m) funopen(sexp_vector(3, (sexp)str, (sexp)len, (sexp)0), sstream_read, sstream_write, sstream_seek, sstream_close) -int sstream_read(void *vec, char *dst, int n); -int sstream_write(void *vec, const char *src, int n); -off_t sstream_seek(void *vec, off_t offset, int whence); -int sstream_close(void *vec); -#endif #define sexp_read_char(p) (getc(sexp_port_stream(p))) #define sexp_push_char(c, p) (ungetc(c, sexp_port_stream(p))) #define sexp_write_char(c, p) (putc(c, sexp_port_stream(p))) #define sexp_write_string(s, p) (fputs(s, sexp_port_stream(p))) #define sexp_printf(p, ...) (fprintf(sexp_port_stream(p), __VA_ARGS__)) #define sexp_flush(p) (fflush(sexp_port_stream(p))) -#else -sexp sexp_read_char(sexp port); -void sexp_push_char(sexp ch, sexp port); -void sexp_write_char(sexp ch, sexp port); -void sexp_write_string(sexp str, sexp port); -void sexp_printf(sexp port, sexp fmt, ...); -#endif - -/***************************** general API ****************************/ sexp sexp_alloc_tagged(size_t size, sexp_uint_t tag); sexp sexp_cons(sexp head, sexp tail); @@ -418,6 +403,7 @@ sexp sexp_assq(sexp x, sexp ls); sexp sexp_length(sexp ls); sexp sexp_c_string(char *str); sexp sexp_make_string(sexp len, sexp ch); +sexp sexp_substring (sexp str, sexp start, sexp end); sexp sexp_make_flonum(double f); int sexp_string_hash(char *str, int acc); sexp sexp_intern(char *str); @@ -437,6 +423,8 @@ sexp sexp_make_input_string_port(sexp str); sexp sexp_make_output_string_port(); sexp sexp_get_output_string(sexp port); sexp sexp_make_exception(sexp kind, sexp message, sexp irritants, sexp file, sexp line); +sexp sexp_type_exception (char *message, sexp obj); +sexp sexp_range_exception (sexp obj, sexp start, sexp end); sexp sexp_print_exception(sexp exn, sexp out); void sexp_init(); From 4736dcaa6dcb3231b836c38c77629a43d6bc3672 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 2 Apr 2009 23:58:48 +0900 Subject: [PATCH 082/154] let-syntax and letrec-syntax --- eval.c | 60 +++++++++++++++++++++++++++++++++++------------- init.scm | 2 +- syntax-rules.scm | 15 ++++++------ 3 files changed, 53 insertions(+), 24 deletions(-) diff --git a/eval.c b/eval.c index 52a30dec..87fc7e91 100644 --- a/eval.c +++ b/eval.c @@ -427,6 +427,8 @@ static sexp analyze_define (sexp x, sexp context) { static sexp analyze_define_syntax (sexp x, sexp context) { sexp name = sexp_cadr(x), cell, proc; + if (sexp_env_parent(sexp_context_env(context))) + return sexp_compile_error("non-top-level define-syntax", sexp_list1(x)); proc = eval_in_context(sexp_caddr(x), context); analyze_check_exception(proc); cell = env_cell_create(sexp_context_env(context), name, SEXP_UNDEF); @@ -434,6 +436,36 @@ static sexp analyze_define_syntax (sexp x, sexp context) { return SEXP_UNDEF; } +static sexp analyze_bind_syntax (sexp ls, sexp eval_ctx, sexp bind_ctx) { + sexp proc; + for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) { + proc = eval_in_context(sexp_cadar(ls), eval_ctx); + analyze_check_exception(proc); + sexp_push(sexp_env_bindings(sexp_context_env(bind_ctx)), + sexp_cons(sexp_caar(ls), + sexp_make_macro(proc, sexp_context_env(eval_ctx)))); + } + return SEXP_UNDEF; +} + +static sexp analyze_let_syntax (sexp x, sexp context) { + sexp env, ctx, tmp; + env = sexp_alloc_type(env, SEXP_ENV); + sexp_env_parent(env) = sexp_env_parent(sexp_context_env(context)); + sexp_env_bindings(env) = sexp_env_bindings(sexp_context_env(context)); + ctx = sexp_child_context(context, sexp_context_lambda(context)); + sexp_context_env(ctx) = env; + tmp = analyze_bind_syntax(sexp_cadr(x), ctx, context); + analyze_check_exception(tmp); + return analyze_seq(sexp_cddr(x), ctx); +} + +static sexp analyze_letrec_syntax (sexp x, sexp context) { + sexp tmp = analyze_bind_syntax(sexp_cadr(x), context, context); + analyze_check_exception(tmp); + return analyze_seq(sexp_cddr(x), context); +} + static sexp analyze (sexp x, sexp context) { sexp op, cell, res; loop: @@ -451,29 +483,25 @@ static sexp analyze (sexp x, sexp context) { if (sexp_corep(op)) { switch (sexp_core_code(op)) { case CORE_DEFINE: - res = analyze_define(x, context); - break; + res = analyze_define(x, context); break; case CORE_SET: - res = analyze_set(x, context); - break; + res = analyze_set(x, context); break; case CORE_LAMBDA: - res = analyze_lambda(x, context); - break; + res = analyze_lambda(x, context); break; case CORE_IF: - res = analyze_if(x, context); - break; + res = analyze_if(x, context); break; case CORE_BEGIN: - res = analyze_seq(x, context); - break; + res = analyze_seq(x, context); break; case CORE_QUOTE: - res = sexp_make_lit(sexp_cadr(x)); - break; + res = sexp_make_lit(sexp_cadr(x)); break; case CORE_DEFINE_SYNTAX: - res = analyze_define_syntax(x, context); - break; + res = analyze_define_syntax(x, context); break; + case CORE_LET_SYNTAX: + res = analyze_let_syntax(x, context); break; + case CORE_LETREC_SYNTAX: + res = analyze_letrec_syntax(x, context); break; default: - res = sexp_compile_error("unknown core form", sexp_list1(op)); - break; + res = sexp_compile_error("unknown core form", sexp_list1(op)); break; } } else if (sexp_macrop(op)) { x = apply(sexp_macro_proc(op), diff --git a/init.scm b/init.scm index eb78c704..027dac98 100644 --- a/init.scm +++ b/init.scm @@ -1,5 +1,5 @@ -;; let-syntax letrec-syntax syntax-rules +;; syntax-rules ;; number->string string->number ;; symbol->string string->symbol ;; with-input-from-file with-output-to-file diff --git a/syntax-rules.scm b/syntax-rules.scm index 687b5384..2433718e 100644 --- a/syntax-rules.scm +++ b/syntax-rules.scm @@ -42,7 +42,7 @@ ((ellipse? p) (cond ((not (null? (cddr p))) - (error "non-trailing ellipse" p)) + (error "non-trailing ellipse")) ((symbol? (car p)) (list _and (list _list? v) (list _let (list (list (car p) v)) @@ -130,7 +130,7 @@ => (lambda (cell) (if (<= (cdr cell) dim) t - (error "too few ...'s for" t tmpl)))) + (error "too few ...'s")))) (else (list _rename (list _quote t))))) ((pair? t) @@ -139,7 +139,7 @@ (ell-dim (+ dim depth)) (ell-vars (free-vars (car t) vars ell-dim))) (if (null? ell-vars) - (error "too many ...'s" tmpl t) + (error "too many ...'s") (let* ((once (lp (car t) ell-dim)) (nest (if (and (null? (cdr ell-vars)) (symbol? once) @@ -164,10 +164,11 @@ (list _lambda (list _expr _rename _compare) (cons _or - (map - (lambda (clause) (expand-pattern (car clause) (cadr clause))) - forms) - (error "no expansion for" _expr)))))))) + (append + (map + (lambda (clause) (expand-pattern (car clause) (cadr clause))) + forms) + (list (list 'else) (list 'error "no expansion")))))))))) ;; Local Variables: ;; eval: (put '_lambda 'scheme-indent-function 1) From 72886b897f6d54021917c11d99c2a232c4b85db2 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Fri, 3 Apr 2009 00:24:17 +0900 Subject: [PATCH 083/154] updating make rules --- Makefile | 35 ++++++++++++++++++++--- eval.c | 85 ------------------------------------------------------ main.c | 87 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 118 insertions(+), 89 deletions(-) create mode 100644 main.c diff --git a/Makefile b/Makefile index c40baa06..5b7b6247 100644 --- a/Makefile +++ b/Makefile @@ -3,7 +3,14 @@ all: chibi-scheme -CFLAGS=-Wall -g -fno-inline -save-temps #-Os +PREFIX=/usr/local +BINDIR=$(PREFIX)/bin +LIBDIR=$(PREFIX)/lib +INCDIR=$(PREFIX)/include/chibi-scheme +MODDIR=$(PREFIX)/share/chibi-scheme + +SO=.dylib +CFLAGS=-Wall -g -fno-inline -save-temps -Os GC_OBJ=./gc/gc.a @@ -16,10 +23,16 @@ sexp.o: sexp.c sexp.h config.h defaults.h Makefile eval.o: eval.c debug.c opcodes.c eval.h sexp.h config.h defaults.h Makefile gcc -c $(CFLAGS) -o $@ $< -# main.o: main.c eval.h sexp.h config.h Makefile -# gcc -c $(CFLAGS) -o $@ $< +main.o: main.c eval.c debug.c opcodes.c eval.h sexp.h config.h defaults.h Makefile + gcc -c $(CFLAGS) -o $@ $< -chibi-scheme: eval.o sexp.o $(GC_OBJ) +libchibisexp.$(SO): sexp.o $(GC_OBJ) + gcc $(LDFLAGS) -shared -dynamiclib -o $@ $^ + +libchibischeme.$(SO): eval.o $(GC_OBJ) + gcc $(LDFLAGS) -shared -dynamiclib -o $@ $^ -lchibisexp + +chibi-scheme: main.o sexp.o $(GC_OBJ) gcc $(CFLAGS) -o $@ $^ clean: @@ -39,3 +52,17 @@ test: chibi-scheme fi; \ done +install: chibi-scheme + cp chibi-scheme $(BINDIR)/ + mkdir -p $(MODDIR) + cp init.scm $(MODDIR)/ + mkdir -p $(INCDIR) + cp *.h $(INCDIR)/ + cp *.$(SO) $(LIBDIR)/ + +uninstall: + rm -f $(BINDIR)/chibi-scheme + rm -f $(LIBDIR)/libchibischeme.$(SO) + rm -f $(LIBDIR)/libchibisexp.$(SO) + rm -f $(INCDIR)/*.h + rm -f $(MODDIR)/*.scm diff --git a/eval.c b/eval.c index 87fc7e91..a94ddcde 100644 --- a/eval.c +++ b/eval.c @@ -1745,88 +1745,3 @@ void scheme_init () { final_resumer = finalize_bytecode(context); } } - -void repl (sexp context) { - sexp obj, res, env, in, out, err; - env = sexp_context_env(context); - in = env_global_ref(env, the_cur_in_symbol, SEXP_FALSE); - out = env_global_ref(env, the_cur_out_symbol, SEXP_FALSE); - err = env_global_ref(env, the_cur_err_symbol, SEXP_FALSE); - while (1) { - sexp_write_string("> ", out); - sexp_flush(out); - obj = sexp_read(in); - if (obj == SEXP_EOF) - break; - if (sexp_exceptionp(obj)) { - sexp_print_exception(obj, err); - } else { - res = eval_in_context(obj, context); - if (res != SEXP_UNDEF) { - sexp_write(res, out); - sexp_write_char('\n', out); - } - } - } -} - -void run_main (int argc, char **argv) { - sexp env, obj, out=NULL, res, context, err_handler; - sexp_uint_t i, quit=0, init_loaded=0; - - env = sexp_make_standard_env(sexp_make_integer(5)); - context = sexp_make_context(NULL, env); - sexp_context_tailp(context) = 0; - emit_push(SEXP_UNDEF, context); - emit(OP_DONE, context); - err_handler = sexp_make_procedure(sexp_make_integer(0), - sexp_make_integer(0), - finalize_bytecode(context), - sexp_make_vector(0, SEXP_UNDEF)); - env_define(env, the_err_handler_symbol, err_handler); - - /* parse options */ - for (i=1; i < argc && argv[i][0] == '-'; i++) { - switch (argv[i][1]) { - case 'e': - case 'p': - if (! init_loaded) { - sexp_load(sexp_c_string(sexp_init_file), env); - init_loaded = 1; - } - obj = sexp_read_from_string(argv[i+1]); - res = eval_in_context(obj, context); - if (argv[i][1] == 'p') { - if (! out) - out = env_global_ref(env, the_cur_out_symbol, SEXP_FALSE); - sexp_write(res, out); - sexp_write_char('\n', out); - } - quit=1; - i++; - break; - case 'q': - init_loaded = 1; - break; - default: - errx(1, "unknown option: %s", argv[i]); - } - } - - if (! quit) { - if (! init_loaded) - sexp_load(sexp_c_string(sexp_init_file), env); - if (i < argc) - for ( ; i < argc; i++) - sexp_load(sexp_c_string(argv[i]), env); - else - repl(context); - } -} - -int main (int argc, char **argv) { - scheme_init(); - run_main(argc, argv); - return 0; -} - diff --git a/main.c b/main.c new file mode 100644 index 00000000..0f6d830a --- /dev/null +++ b/main.c @@ -0,0 +1,87 @@ + +#include "eval.c" + +void repl (sexp context) { + sexp obj, res, env, in, out, err; + env = sexp_context_env(context); + in = env_global_ref(env, the_cur_in_symbol, SEXP_FALSE); + out = env_global_ref(env, the_cur_out_symbol, SEXP_FALSE); + err = env_global_ref(env, the_cur_err_symbol, SEXP_FALSE); + while (1) { + sexp_write_string("> ", out); + sexp_flush(out); + obj = sexp_read(in); + if (obj == SEXP_EOF) + break; + if (sexp_exceptionp(obj)) { + sexp_print_exception(obj, err); + } else { + res = eval_in_context(obj, context); + if (res != SEXP_UNDEF) { + sexp_write(res, out); + sexp_write_char('\n', out); + } + } + } +} + +void run_main (int argc, char **argv) { + sexp env, obj, out=NULL, res, context, err_handler; + sexp_uint_t i, quit=0, init_loaded=0; + + env = sexp_make_standard_env(sexp_make_integer(5)); + context = sexp_make_context(NULL, env); + sexp_context_tailp(context) = 0; + emit_push(SEXP_UNDEF, context); + emit(OP_DONE, context); + err_handler = sexp_make_procedure(sexp_make_integer(0), + sexp_make_integer(0), + finalize_bytecode(context), + sexp_make_vector(0, SEXP_UNDEF)); + env_define(env, the_err_handler_symbol, err_handler); + + /* parse options */ + for (i=1; i < argc && argv[i][0] == '-'; i++) { + switch (argv[i][1]) { + case 'e': + case 'p': + if (! init_loaded) { + sexp_load(sexp_c_string(sexp_init_file), env); + init_loaded = 1; + } + obj = sexp_read_from_string(argv[i+1]); + res = eval_in_context(obj, context); + if (argv[i][1] == 'p') { + if (! out) + out = env_global_ref(env, the_cur_out_symbol, SEXP_FALSE); + sexp_write(res, out); + sexp_write_char('\n', out); + } + quit=1; + i++; + break; + case 'q': + init_loaded = 1; + break; + default: + errx(1, "unknown option: %s", argv[i]); + } + } + + if (! quit) { + if (! init_loaded) + sexp_load(sexp_c_string(sexp_init_file), env); + if (i < argc) + for ( ; i < argc; i++) + sexp_load(sexp_c_string(argv[i]), env); + else + repl(context); + } +} + +int main (int argc, char **argv) { + scheme_init(); + run_main(argc, argv); + return 0; +} + From 177003299e201f868d5403134ca4eb4791a32f0b Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Fri, 3 Apr 2009 01:04:46 +0900 Subject: [PATCH 084/154] mutable parameters --- eval.c | 19 +++--- init.scm | 17 ++++- opcodes.c | 191 +++++++++++++++++++++++++++--------------------------- sexp.h | 3 +- 4 files changed, 125 insertions(+), 105 deletions(-) diff --git a/eval.c b/eval.c index a94ddcde..3e664860 100644 --- a/eval.c +++ b/eval.c @@ -665,10 +665,11 @@ static void generate_opcode_app (sexp app, sexp context) { /* maybe push the default for an optional argument */ if ((num_args == sexp_opcode_num_args(op)) && sexp_opcode_variadic_p(op) - && sexp_opcode_data(op) - && sexp_opcode_opt_param_p(op)) { - emit_push(sexp_opcode_data(op), context); - emit(OP_CDR, context); + && sexp_opcode_default(op) + && (sexp_opcode_class(op) != OPC_PARAMETER)) { + emit_push(sexp_opcode_default(op), context); + if (sexp_opcode_opt_param_p(op)) + emit(OP_CDR, context); sexp_context_depth(context)++; num_args++; } @@ -714,8 +715,8 @@ static void generate_opcode_app (sexp app, sexp context) { emit_word((sexp_uint_t)sexp_opcode_data(op), context); break; case OPC_PARAMETER: - emit_push(sexp_opcode_data(op), context); - emit(OP_CDR, context); + emit_push(sexp_opcode_default(op), context); + emit((num_args == 0 ? OP_CDR : OP_SET_CDR), context); default: emit(sexp_opcode_code(op), context); } @@ -1654,10 +1655,10 @@ static sexp sexp_make_standard_env (sexp version) { op = &opcodes[i]; if ((! standard_env_syms_interned_p) && sexp_opcode_opt_param_p(op) - && sexp_opcode_data(op)) { - sym = sexp_intern((char*)sexp_opcode_data(op)); + && sexp_opcode_default(op)) { + sym = sexp_intern((char*)sexp_opcode_default(op)); cell = env_cell_create(e, sym, SEXP_UNDEF); - sexp_opcode_data(op) = cell; + sexp_opcode_default(op) = cell; } env_define(e, sexp_intern(sexp_opcode_name(op)), op); } diff --git a/init.scm b/init.scm index 027dac98..9348286e 100644 --- a/init.scm +++ b/init.scm @@ -2,7 +2,6 @@ ;; syntax-rules ;; number->string string->number ;; symbol->string string->symbol -;; with-input-from-file with-output-to-file ;; provide c[ad]{2,4}r @@ -446,6 +445,22 @@ (close-output-port in) res)) +(define (with-input-from-file file thunk) + (let ((old-in (current-input-port)) + (tmp-in (open-input-file file))) + (current-input-port tmp-in) + (let ((res (thunk))) + (current-input-port old-in) + res))) + +(define (with-output-to-file file thunk) + (let ((old-out (current-input-port)) + (tmp-out (open-output-file file))) + (current-input-port tmp-out) + (let ((res (thunk))) + (current-output-port old-out) + res))) + ;; values (define *values-tag* (list 'values)) diff --git a/opcodes.c b/opcodes.c index f4f326b4..10347def 100644 --- a/opcodes.c +++ b/opcodes.c @@ -1,60 +1,63 @@ -#define _OP(c,o,n,m,t,u,i,s,d,p) {.tag=SEXP_OPCODE, .value={.opcode={c, o, n, m, t, u, i, s, d, p}}} -#define _FN(o,n,t,u,s,f) _OP(OPC_FOREIGN, o, n, 0, t, u, 0, s, (sexp)f, NULL) -#define _FN0(s, f) _FN(OP_FCALL0, 0, 0, 0, s, f) -#define _FN1(t, s, f) _FN(OP_FCALL1, 1, t, 0, s, f) -#define _FN2(t, u, s, f) _FN(OP_FCALL2, 2, t, u, s, f) -#define _FN3(t, u, s, f) _FN(OP_FCALL3, 3, t, u, s, f) -#define _FN4(t, u, s, f) _FN(OP_FCALL4, 4, t, u, s, f) -#define _PARAM(n,a,t) _OP(OPC_PARAMETER, OP_NOOP, 0, 2, t, 0, 0, n, a, NULL) +#define _OP(c,o,n,m,t,u,i,s,f,d) \ + {.tag=SEXP_OPCODE, \ + .value={.opcode={c, o, n, m, t, u, i, s, f, d, NULL}}} +#define _FN(o,n,m,t,u,s,f,d) _OP(OPC_FOREIGN, o, n, m, t, u, 0, s, f, (sexp)d) +#define _FN0(s, f, d) _FN(OP_FCALL0, 0, 0, 0, 0, s, f, d) +#define _FN1(t, s, f, d) _FN(OP_FCALL1, 1, 0, t, 0, s, f, d) +#define _FN2(t, u, s, f, d) _FN(OP_FCALL2, 2, 0, t, u, s, f, d) +#define _FN2OPT(t, u, s, f, d) _FN(OP_FCALL2, 1, 1, t, u, s, f, d) +#define _FN3(t, u, s, f, d) _FN(OP_FCALL3, 3, 0, t, u, s, f, d) +#define _FN4(t, u, s, f, d) _FN(OP_FCALL4, 4, 0, t, u, s, f, d) +#define _PARAM(n, a, t) _OP(OPC_PARAMETER, OP_NOOP, 0, 3, t, 0, 0, n, a, 0) static struct sexp_struct opcodes[] = { -_OP(OPC_ACCESSOR, OP_CAR, 1, 0, SEXP_PAIR, 0, 0, "car", NULL, NULL), -_OP(OPC_ACCESSOR, OP_SET_CAR, 2, 0, SEXP_PAIR, 0, 0, "set-car!", NULL, NULL), -_OP(OPC_ACCESSOR, OP_CDR, 1, 0, SEXP_PAIR, 0, 0, "cdr", NULL, NULL), -_OP(OPC_ACCESSOR, OP_SET_CDR, 2, 0, SEXP_PAIR, 0, 0, "set-cdr!", NULL, NULL), -_OP(OPC_ACCESSOR, OP_VECTOR_REF,2,0, SEXP_VECTOR, SEXP_FIXNUM, 0,"vector-ref", NULL, NULL), -_OP(OPC_ACCESSOR, OP_VECTOR_SET,3,0, SEXP_VECTOR, SEXP_FIXNUM, 0,"vector-set!", NULL, NULL), -_OP(OPC_ACCESSOR, OP_VECTOR_LENGTH,1,0, SEXP_VECTOR, 0, 0,"vector-length", NULL, NULL), -_OP(OPC_ACCESSOR, OP_STRING_REF,2,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-ref", NULL, NULL), -_OP(OPC_ACCESSOR, OP_STRING_SET,3,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-set!", NULL, NULL), -_OP(OPC_ACCESSOR, OP_STRING_LENGTH,1,0, SEXP_STRING, 0, 0,"string-length", NULL, NULL), -_OP(OPC_GENERIC, OP_FIX2FLO, 1, 0, 0, 0, 0, "exact->inexact", NULL, NULL), -_OP(OPC_GENERIC, OP_FLO2FIX, 1, 0, 0, 0, 0, "inexact->exact", NULL, NULL), -_OP(OPC_GENERIC, OP_CHAR2INT, 1, 0, SEXP_CHAR, 0, 0, "char->integer", NULL, NULL), -_OP(OPC_GENERIC, OP_INT2CHAR, 1, 0, SEXP_FIXNUM, 0, 0, "integer->char", NULL, NULL), -_OP(OPC_GENERIC, OP_CHAR_UPCASE, 1, 0, SEXP_CHAR, 0, 0, "char-upcase", NULL, NULL), -_OP(OPC_GENERIC, OP_CHAR_DOWNCASE, 1, 0, SEXP_CHAR, 0, 0, "char-downcase", NULL, NULL), -_OP(OPC_ARITHMETIC, OP_ADD, 0, 1, SEXP_FIXNUM, 0, 0, "+", NULL, NULL), -_OP(OPC_ARITHMETIC, OP_MUL, 0, 1, SEXP_FIXNUM, 0, 0, "*", NULL, NULL), -_OP(OPC_ARITHMETIC_INV, OP_SUB, 0, 1, SEXP_FIXNUM, 0, OP_NEGATIVE, "-", NULL, NULL), -_OP(OPC_ARITHMETIC_INV, OP_DIV, 0, 1, SEXP_FIXNUM, 0, OP_INVERSE, "/", NULL, NULL), -_OP(OPC_ARITHMETIC, OP_QUOTIENT, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, 0, "quotient", NULL, NULL), -_OP(OPC_ARITHMETIC, OP_REMAINDER, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, 0, "remainder", NULL, NULL), -_OP(OPC_ARITHMETIC_CMP, OP_LT, 0, 1, SEXP_FIXNUM, 0, 0, "<", NULL, NULL), -_OP(OPC_ARITHMETIC_CMP, OP_LE, 0, 1, SEXP_FIXNUM, 0, 0, "<=", NULL, NULL), -_OP(OPC_ARITHMETIC_CMP, OP_LT, 0, 1, SEXP_FIXNUM, 0, 1, ">", NULL, NULL), -_OP(OPC_ARITHMETIC_CMP, OP_LE, 0, 1, SEXP_FIXNUM, 0, 1, ">=", NULL, NULL), -_OP(OPC_ARITHMETIC_CMP, OP_EQN, 0, 1, SEXP_FIXNUM, 0, 0, "=", NULL, NULL), -_OP(OPC_PREDICATE, OP_EQ, 2, 0, 0, 0, 0, "eq?", NULL, NULL), -_OP(OPC_CONSTRUCTOR, OP_CONS, 2, 0, 0, 0, 0, "cons", NULL, NULL), -_OP(OPC_CONSTRUCTOR, OP_MAKE_VECTOR, 2, 0, SEXP_FIXNUM, 0, 0, "make-vector", NULL, NULL), -_OP(OPC_CONSTRUCTOR, OP_MAKE_PROCEDURE, 4, 0, 0, 0, 0, "make-procedure", NULL, NULL), -_OP(OPC_TYPE_PREDICATE, OP_NULLP, 1, 0, 0, 0, 0, "null?", NULL, NULL), -_OP(OPC_TYPE_PREDICATE, OP_EOFP, 1, 0, 0, 0, 0, "eof-object?", NULL, NULL), -_OP(OPC_TYPE_PREDICATE, OP_SYMBOLP, 1, 0, 0, 0, 0, "symbol?", NULL, NULL), -_OP(OPC_TYPE_PREDICATE, OP_CHARP, 1, 0, 0, 0, 0, "char?", NULL, NULL), -_OP(OPC_TYPE_PREDICATE, OP_INTEGERP, 1, 0, 0, 0, 0, "fixnum?", NULL, NULL), -_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "pair?", (sexp)SEXP_PAIR, NULL), -_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "string?", (sexp)SEXP_STRING, NULL), -_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "vector?", (sexp)SEXP_VECTOR, NULL), -_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "flonum?", (sexp)SEXP_FLONUM, NULL), -_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "procedure?", (sexp)SEXP_PROCEDURE, NULL), -_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "input-port?", (sexp)SEXP_IPORT, NULL), -_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "output-port?", (sexp)SEXP_OPORT, NULL), -_OP(OPC_GENERIC, OP_APPLY1, 2, 0, SEXP_PROCEDURE, SEXP_PAIR, 0, "apply1", NULL, NULL), -_OP(OPC_GENERIC, OP_CALLCC, 1, SEXP_PROCEDURE, 0, 0, 0, "call-with-current-continuation", NULL, NULL), -_OP(OPC_GENERIC, OP_ERROR, 1, SEXP_STRING, 0, 0, 0, "error", NULL, NULL), +_OP(OPC_ACCESSOR, OP_CAR, 1, 0, SEXP_PAIR, 0, 0, "car", 0, NULL), +_OP(OPC_ACCESSOR, OP_SET_CAR, 2, 0, SEXP_PAIR, 0, 0, "set-car!", 0, NULL), +_OP(OPC_ACCESSOR, OP_CDR, 1, 0, SEXP_PAIR, 0, 0, "cdr", 0, NULL), +_OP(OPC_ACCESSOR, OP_SET_CDR, 2, 0, SEXP_PAIR, 0, 0, "set-cdr!", 0, NULL), +_OP(OPC_ACCESSOR, OP_VECTOR_REF,2,0, SEXP_VECTOR, SEXP_FIXNUM, 0,"vector-ref", 0, NULL), +_OP(OPC_ACCESSOR, OP_VECTOR_SET,3,0, SEXP_VECTOR, SEXP_FIXNUM, 0,"vector-set!", 0, NULL), +_OP(OPC_ACCESSOR, OP_VECTOR_LENGTH,1,0, SEXP_VECTOR, 0, 0,"vector-length", 0, NULL), +_OP(OPC_ACCESSOR, OP_STRING_REF,2,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-ref", 0, NULL), +_OP(OPC_ACCESSOR, OP_STRING_SET,3,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-set!", 0, NULL), +_OP(OPC_ACCESSOR, OP_STRING_LENGTH,1,0, SEXP_STRING, 0, 0,"string-length", 0, NULL), +_OP(OPC_GENERIC, OP_FIX2FLO, 1, 0, 0, 0, 0, "exact->inexact", 0, NULL), +_OP(OPC_GENERIC, OP_FLO2FIX, 1, 0, 0, 0, 0, "inexact->exact", 0, NULL), +_OP(OPC_GENERIC, OP_CHAR2INT, 1, 0, SEXP_CHAR, 0, 0, "char->integer", 0, NULL), +_OP(OPC_GENERIC, OP_INT2CHAR, 1, 0, SEXP_FIXNUM, 0, 0, "integer->char", 0, NULL), +_OP(OPC_GENERIC, OP_CHAR_UPCASE, 1, 0, SEXP_CHAR, 0, 0, "char-upcase", 0, NULL), +_OP(OPC_GENERIC, OP_CHAR_DOWNCASE, 1, 0, SEXP_CHAR, 0, 0, "char-downcase", 0, NULL), +_OP(OPC_ARITHMETIC, OP_ADD, 0, 1, SEXP_FIXNUM, 0, 0, "+", sexp_make_integer(0), NULL), +_OP(OPC_ARITHMETIC, OP_MUL, 0, 1, SEXP_FIXNUM, 0, 0, "*", sexp_make_integer(1), NULL), +_OP(OPC_ARITHMETIC_INV, OP_SUB, 0, 1, SEXP_FIXNUM, 0, OP_NEGATIVE, "-", 0, NULL), +_OP(OPC_ARITHMETIC_INV, OP_DIV, 0, 1, SEXP_FIXNUM, 0, OP_INVERSE, "/", 0, NULL), +_OP(OPC_ARITHMETIC, OP_QUOTIENT, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, 0, "quotient", 0, NULL), +_OP(OPC_ARITHMETIC, OP_REMAINDER, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, 0, "remainder", 0, NULL), +_OP(OPC_ARITHMETIC_CMP, OP_LT, 0, 1, SEXP_FIXNUM, 0, 0, "<", 0, NULL), +_OP(OPC_ARITHMETIC_CMP, OP_LE, 0, 1, SEXP_FIXNUM, 0, 0, "<=", 0, NULL), +_OP(OPC_ARITHMETIC_CMP, OP_LT, 0, 1, SEXP_FIXNUM, 0, 1, ">", 0, NULL), +_OP(OPC_ARITHMETIC_CMP, OP_LE, 0, 1, SEXP_FIXNUM, 0, 1, ">=", 0, NULL), +_OP(OPC_ARITHMETIC_CMP, OP_EQN, 0, 1, SEXP_FIXNUM, 0, 0, "=", 0, NULL), +_OP(OPC_PREDICATE, OP_EQ, 2, 0, 0, 0, 0, "eq?", 0, NULL), +_OP(OPC_CONSTRUCTOR, OP_CONS, 2, 0, 0, 0, 0, "cons", 0, NULL), +_OP(OPC_CONSTRUCTOR, OP_MAKE_VECTOR, 1, 1, SEXP_FIXNUM, 0, 0, "make-vector", SEXP_UNDEF, NULL), +_OP(OPC_CONSTRUCTOR, OP_MAKE_PROCEDURE, 4, 0, 0, 0, 0, "make-procedure", 0, NULL), +_OP(OPC_TYPE_PREDICATE, OP_NULLP, 1, 0, 0, 0, 0, "null?", 0, NULL), +_OP(OPC_TYPE_PREDICATE, OP_EOFP, 1, 0, 0, 0, 0, "eof-object?", 0, NULL), +_OP(OPC_TYPE_PREDICATE, OP_SYMBOLP, 1, 0, 0, 0, 0, "symbol?", 0, NULL), +_OP(OPC_TYPE_PREDICATE, OP_CHARP, 1, 0, 0, 0, 0, "char?", 0, NULL), +_OP(OPC_TYPE_PREDICATE, OP_INTEGERP, 1, 0, 0, 0, 0, "fixnum?", 0, NULL), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "pair?", 0, (sexp)SEXP_PAIR), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "string?", 0, (sexp)SEXP_STRING), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "vector?", 0, (sexp)SEXP_VECTOR), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "flonum?", 0, (sexp)SEXP_FLONUM), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "procedure?", 0, (sexp)SEXP_PROCEDURE), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "input-port?", 0, (sexp)SEXP_IPORT), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "output-port?", 0, (sexp)SEXP_OPORT), +_OP(OPC_GENERIC, OP_APPLY1, 2, 0, SEXP_PROCEDURE, SEXP_PAIR, 0, "apply1", 0, NULL), +_OP(OPC_GENERIC, OP_CALLCC, 1, SEXP_PROCEDURE, 0, 0, 0, "call-with-current-continuation", 0, NULL), +_OP(OPC_GENERIC, OP_ERROR, 1, SEXP_STRING, 0, 0, 0, "error", 0, NULL), _OP(OPC_IO, OP_WRITE, 1, 3, 0, SEXP_OPORT, 0, "write", (sexp)"*current-output-port*", NULL), _OP(OPC_IO, OP_DISPLAY, 1, 3, 0, SEXP_OPORT, 0, "display", (sexp)"*current-output-port*", NULL), _OP(OPC_IO, OP_WRITE_CHAR, 1, 3, 0, SEXP_OPORT, 0, "write-char", (sexp)"*current-output-port*", NULL), @@ -64,56 +67,56 @@ _OP(OPC_IO, OP_READ, 0, 3, 0, SEXP_IPORT, 0, "read", (sexp)"*current-input-port* _OP(OPC_IO, OP_READ_CHAR, 0, 3, 0, SEXP_IPORT, 0, "read-char", (sexp)"*current-input-port*", NULL), _OP(OPC_IO, OP_PEEK_CHAR, 0, 3, 0, SEXP_IPORT, 0, "peek-char", (sexp)"*current-input-port*", NULL), _OP(OPC_GENERIC, OP_EVAL, 1, 3, 0, 0, 0, "eval", (sexp)"*interaction-environment*", NULL), -_FN2(0, 0, "equal?", sexp_equalp), -_FN1(0, "list?", sexp_listp), -_FN1(0, "identifier?", sexp_identifierp), -_FN4(0, SEXP_ENV, "identifier=?", sexp_identifier_eq), -_FN1(SEXP_PAIR, "length", sexp_length), -_FN1(SEXP_PAIR, "reverse", sexp_reverse), -_FN1(SEXP_PAIR, "list->vector", sexp_list_to_vector), -_FN1(SEXP_STRING, "open-input-file", sexp_open_input_file), -_FN1(SEXP_STRING, "open-output-file", sexp_open_output_file), -_FN1(SEXP_IPORT, "close-input-port", sexp_close_port), -_FN1(SEXP_OPORT, "close-output-port", sexp_close_port), -_FN1(SEXP_FIXNUM, "null-environment", sexp_make_null_env), -_FN1(SEXP_FIXNUM, "scheme-report-environment", sexp_make_standard_env), -_FN2(0, SEXP_ENV, "%load", sexp_load), -_FN2(SEXP_FIXNUM, SEXP_CHAR, "make-string", sexp_make_string), -_FN2(SEXP_STRING, SEXP_STRING, "string-cmp", sexp_string_cmp), -_FN2(SEXP_STRING, SEXP_STRING, "string-cmp-ci", sexp_string_cmp_ci), -_FN3(SEXP_STRING, SEXP_FIXNUM, "substring", sexp_substring), -_FN1(SEXP_PAIR, "string-concatenate", sexp_string_concatenate), -_FN2(0, SEXP_PAIR, "memq", sexp_memq), -_FN2(0, SEXP_PAIR, "assq", sexp_assq), -_FN3(SEXP_ENV, SEXP_PAIR, "make-syntactic-closure", sexp_make_synclo), +_FN2(0, 0, "equal?", 0, sexp_equalp), +_FN1(0, "list?", 0, sexp_listp), +_FN1(0, "identifier?", 0, sexp_identifierp), +_FN4(0, SEXP_ENV, "identifier=?", 0, sexp_identifier_eq), +_FN1(SEXP_PAIR, "length", 0, sexp_length), +_FN1(SEXP_PAIR, "reverse", 0, sexp_reverse), +_FN1(SEXP_PAIR, "list->vector", 0, sexp_list_to_vector), +_FN1(SEXP_STRING, "open-input-file", 0, sexp_open_input_file), +_FN1(SEXP_STRING, "open-output-file", 0, sexp_open_output_file), +_FN1(SEXP_IPORT, "close-input-port", 0, sexp_close_port), +_FN1(SEXP_OPORT, "close-output-port", 0, sexp_close_port), +_FN1(SEXP_FIXNUM, "null-environment", 0, sexp_make_null_env), +_FN1(SEXP_FIXNUM, "scheme-report-environment", 0, sexp_make_standard_env), +_FN2(SEXP_STRING, SEXP_ENV, "%load", 0, sexp_load), +_FN2OPT(SEXP_FIXNUM, SEXP_CHAR, "make-string", sexp_make_character(' '), sexp_make_string), +_FN2(SEXP_STRING, SEXP_STRING, "string-cmp", 0, sexp_string_cmp), +_FN2(SEXP_STRING, SEXP_STRING, "string-cmp-ci", 0, sexp_string_cmp_ci), +_FN3(SEXP_STRING, SEXP_FIXNUM, "substring", 0, sexp_substring), +_FN1(SEXP_PAIR, "string-concatenate", 0, sexp_string_concatenate), +_FN2(0, SEXP_PAIR, "memq", 0, sexp_memq), +_FN2(0, SEXP_PAIR, "assq", 0, sexp_assq), +_FN3(SEXP_ENV, SEXP_PAIR, "make-syntactic-closure", 0, sexp_make_synclo), _PARAM("current-input-port", (sexp)"*current-input-port*", SEXP_IPORT), _PARAM("current-output-port", (sexp)"*current-output-port*", SEXP_OPORT), _PARAM("current-error-port", (sexp)"*current-error-port*", SEXP_OPORT), _PARAM("current-error-handler", (sexp)"*current-error-handler*", SEXP_PROCEDURE), _PARAM("interaction-environment", (sexp)"*interaction-environment*", SEXP_ENV), #if USE_MATH -_FN1(0, "exp", sexp_exp), -_FN1(0, "log", sexp_log), -_FN1(0, "sin", sexp_sin), -_FN1(0, "cos", sexp_cos), -_FN1(0, "tan", sexp_tan), -_FN1(0, "asin", sexp_asin), -_FN1(0, "acos", sexp_acos), -_FN1(0, "atan", sexp_atan), -_FN1(0, "sqrt", sexp_sqrt), -_FN1(0, "round", sexp_round), -_FN1(0, "truncate", sexp_trunc), -_FN1(0, "floor", sexp_floor), -_FN1(0, "ceiling", sexp_ceiling), -_FN2(0, 0, "expt", sexp_expt), +_FN1(0, "exp", 0, sexp_exp), +_FN1(0, "log", 0, sexp_log), +_FN1(0, "sin", 0, sexp_sin), +_FN1(0, "cos", 0, sexp_cos), +_FN1(0, "tan", 0, sexp_tan), +_FN1(0, "asin", 0, sexp_asin), +_FN1(0, "acos", 0, sexp_acos), +_FN1(0, "atan", 0, sexp_atan), +_FN1(0, "sqrt", 0, sexp_sqrt), +_FN1(0, "round", 0, sexp_round), +_FN1(0, "truncate", 0, sexp_trunc), +_FN1(0, "floor", 0, sexp_floor), +_FN1(0, "ceiling", 0, sexp_ceiling), +_FN2(0, 0, "expt", 0, sexp_expt), #endif #if USE_STRING_STREAMS -_FN0("open-output-string", sexp_make_output_string_port), -_FN1(SEXP_STRING, "open-input-string", sexp_make_input_string_port), -_FN1(SEXP_OPORT, "get-output-string", sexp_get_output_string), +_FN0("open-output-string", 0, sexp_make_output_string_port), +_FN1(SEXP_STRING, "open-input-string", 0, sexp_make_input_string_port), +_FN1(SEXP_OPORT, "get-output-string", 0, sexp_get_output_string), #endif #if USE_DEBUG -_FN2(SEXP_PROCEDURE, SEXP_OPORT, "disasm", sexp_disasm), +_FN2(SEXP_PROCEDURE, SEXP_OPORT, "disasm", 0, sexp_disasm), #endif }; diff --git a/sexp.h b/sexp.h index ae4835b2..b9e820f2 100644 --- a/sexp.h +++ b/sexp.h @@ -132,7 +132,7 @@ struct sexp_struct { unsigned char op_class, code, num_args, flags, arg1_type, arg2_type, inverse; char *name; - sexp data, proc; + sexp dflt, data, proc; } opcode; struct { char code; @@ -301,6 +301,7 @@ struct sexp_struct { #define sexp_opcode_arg2_type(x) ((x)->value.opcode.arg2_type) #define sexp_opcode_inverse(x) ((x)->value.opcode.inverse) #define sexp_opcode_name(x) ((x)->value.opcode.name) +#define sexp_opcode_default(x) ((x)->value.opcode.dflt) #define sexp_opcode_data(x) ((x)->value.opcode.data) #define sexp_opcode_proc(x) ((x)->value.opcode.proc) From 9a816f504f978577b9ccfa66f5cb436f7dce3b31 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Fri, 3 Apr 2009 01:26:38 +0900 Subject: [PATCH 085/154] string->number and number->string --- init.scm | 28 +++++++++++++++++++++++++++- 1 file changed, 27 insertions(+), 1 deletion(-) diff --git a/init.scm b/init.scm index 9348286e..5270fdf2 100644 --- a/init.scm +++ b/init.scm @@ -1,6 +1,5 @@ ;; syntax-rules -;; number->string string->number ;; symbol->string string->symbol ;; provide c[ad]{2,4}r @@ -397,6 +396,33 @@ (define magnitude abs) (define (angle z) (if (< z 0) 3.141592653589793 0)) +(define (digit-char n) (integer->char (+ n (char->integer #\0)))) +(define (digit-value ch) + (if (char-numeric? ch) + (- (char->integer ch) (char->integer #\0)) + (and (<= 65 (char->integer (char-upcase ch)) 70) + (- (char->integer (char-upcase ch)) 65)))) + +(define (number->string n . o) + (if (if (null? o) #t (eq? 10 (car o))) + (call-with-output-string (lambda (out) (write n out))) + (let lp ((n n) (d (car o)) (res '())) + (if (> n 0) + (lp (quotient n d) d (cons (digit-char (remainder n d)) res)) + (list->string res))))) + +(define (string->number str . o) + (let ((res + (if (if (null? o) #t (eq? 10 (car o))) + (call-with-input-string str (lambda (in) (read in))) + (let ((len (string-length str))) + (let lp ((i 0) (d (car o)) (acc 0)) + (if (>= i len) + acc + (let ((v (digit-value (string-ref str i)))) + (and v (lp (+ i 1) d (+ (* acc d) v)))))))))) + (and (number? res) res))) + ;; vector utils (define (list->vector ls) From 2983b10af15bd1fb3e985c5a0b36bf59176c1f60 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Fri, 3 Apr 2009 02:02:59 +0900 Subject: [PATCH 086/154] switching to chained buckets for symbol table --- Makefile | 2 +- defaults.h | 4 ++++ init.scm | 6 ++--- opcodes.c | 1 + sexp.c | 68 ++++++++++++++++++++++++------------------------------ sexp.h | 3 ++- 6 files changed, 41 insertions(+), 43 deletions(-) diff --git a/Makefile b/Makefile index 5b7b6247..e27b1793 100644 --- a/Makefile +++ b/Makefile @@ -10,7 +10,7 @@ INCDIR=$(PREFIX)/include/chibi-scheme MODDIR=$(PREFIX)/share/chibi-scheme SO=.dylib -CFLAGS=-Wall -g -fno-inline -save-temps -Os +CFLAGS=-Wall -g -save-temps -Os GC_OBJ=./gc/gc.a diff --git a/defaults.h b/defaults.h index 25c99b47..c463c75e 100644 --- a/defaults.h +++ b/defaults.h @@ -31,6 +31,10 @@ #define USE_HUFF_SYMS 1 #endif +#ifndef USE_HASH_SYMS +#define USE_HASH_SYMS 1 +#endif + #ifndef USE_DEBUG #define USE_DEBUG 1 #endif diff --git a/init.scm b/init.scm index 5270fdf2..16e8a236 100644 --- a/init.scm +++ b/init.scm @@ -1,7 +1,4 @@ -;; syntax-rules -;; symbol->string string->symbol - ;; provide c[ad]{2,4}r (define (caar x) (car (car x))) @@ -314,6 +311,9 @@ ;; string utils +(define (symbol->string sym) + (call-with-output-string (lambda (out) (write sym out)))) + (define (list->string ls) (let ((str (make-string (length ls) #\space))) (let lp ((ls ls) (i 0)) diff --git a/opcodes.c b/opcodes.c index 10347def..9e94820f 100644 --- a/opcodes.c +++ b/opcodes.c @@ -85,6 +85,7 @@ _FN2OPT(SEXP_FIXNUM, SEXP_CHAR, "make-string", sexp_make_character(' '), sexp_ma _FN2(SEXP_STRING, SEXP_STRING, "string-cmp", 0, sexp_string_cmp), _FN2(SEXP_STRING, SEXP_STRING, "string-cmp-ci", 0, sexp_string_cmp_ci), _FN3(SEXP_STRING, SEXP_FIXNUM, "substring", 0, sexp_substring), +_FN1(SEXP_STRING, "string->symbol", 0, sexp_string_to_symbol), _FN1(SEXP_PAIR, "string-concatenate", 0, sexp_string_concatenate), _FN2(0, SEXP_PAIR, "memq", 0, sexp_memq), _FN2(0, SEXP_PAIR, "assq", 0, sexp_assq), diff --git a/sexp.c b/sexp.c index 936d70e3..bedd30e2 100644 --- a/sexp.c +++ b/sexp.c @@ -45,13 +45,13 @@ static int is_separator(int c) { return 0 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); +#if USE_HASH_SYMS + bucket = (sexp_string_hash(p, res) % SEXP_SYMBOL_TABLE_SIZE); +#else + bucket = 0; +#endif len = strlen(str); + for (ls=symbol_table[bucket]; sexp_pairp(ls); ls=sexp_cdr(ls)) + if (strncmp(str, sexp_symbol_data(sexp_car(ls)), len) == 0) + return sexp_car(ls); + + /* not found, make a new symbol */ + sym = sexp_alloc_type(symbol, SEXP_SYMBOL); 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_push(symbol_table[bucket], sym); + return sym; +} + +sexp sexp_string_to_symbol (sexp str) { + return sexp_intern(sexp_string_data(str)); } sexp sexp_make_vector(sexp len, sexp dflt) { @@ -1035,6 +1025,7 @@ sexp sexp_read_from_string(char *str) { } void sexp_init() { + int i; if (! sexp_initialized_p) { sexp_initialized_p = 1; #if USE_BOEHM @@ -1042,7 +1033,8 @@ void sexp_init() { GC_add_roots((char*)&symbol_table, ((char*)&symbol_table)+sizeof(symbol_table)+1); #endif - symbol_table = sexp_alloc(symbol_table_primes[0]*sizeof(sexp)); + for (i=0; i Date: Fri, 3 Apr 2009 02:23:07 +0900 Subject: [PATCH 087/154] playing with linux fmemopen --- config.h | 3 +++ main.c | 2 ++ sexp.c | 40 +++++++++++++++++++++++++++++----------- 3 files changed, 34 insertions(+), 11 deletions(-) diff --git a/config.h b/config.h index da09e126..cf480383 100644 --- a/config.h +++ b/config.h @@ -14,6 +14,9 @@ /* uncomment this to disable huffman-coded immediate symbols */ /* #define USE_HUFF_SYMS 0 */ +/* uncomment this to just use a single list for hash tables */ +/* #define USE_HASH_SYMS 0 */ + /* uncomment this to disable string ports */ /* #define USE_STRING_STREAMS 0 */ diff --git a/main.c b/main.c index 0f6d830a..8ecda29b 100644 --- a/main.c +++ b/main.c @@ -43,6 +43,7 @@ void run_main (int argc, char **argv) { /* parse options */ for (i=1; i < argc && argv[i][0] == '-'; i++) { switch (argv[i][1]) { +#if USE_STRING_STREAMS case 'e': case 'p': if (! init_loaded) { @@ -60,6 +61,7 @@ void run_main (int argc, char **argv) { quit=1; i++; break; +#endif case 'q': init_loaded = 1; break; diff --git a/sexp.c b/sexp.c index bedd30e2..b8974b93 100644 --- a/sexp.c +++ b/sexp.c @@ -385,9 +385,8 @@ sexp sexp_make_vector(sexp len, sexp dflt) { if (! clen) return the_empty_vector; v = sexp_alloc_type(vector, SEXP_VECTOR); x = (sexp*) sexp_alloc(clen*sizeof(sexp)); - for (i=0; i= len) return 0; @@ -437,7 +436,7 @@ int sstream_read(void *vec, char *dst, int n) { return n; } -int sstream_write(void *vec, const char *src, int n) { +int sstream_write (void *vec, const char *src, int n) { sexp_uint_t len, pos, newpos; sexp newbuf; len = sexp_unbox_integer(sexp_stream_size(vec)); @@ -456,7 +455,7 @@ int sstream_write(void *vec, const char *src, int n) { return n; } -off_t sstream_seek(void *vec, off_t offset, int whence) { +off_t sstream_seek (void *vec, off_t offset, int whence) { sexp_sint_t pos; if (whence == SEEK_SET) { pos = offset; @@ -469,7 +468,7 @@ off_t sstream_seek(void *vec, off_t offset, int whence) { return pos; } -sexp sexp_make_input_string_port(sexp str) { +sexp sexp_make_input_string_port (sexp str) { FILE *in; sexp res, cookie; cookie = sexp_vector(3, str, sexp_make_integer(sexp_string_length(str)), @@ -480,7 +479,7 @@ sexp sexp_make_input_string_port(sexp str) { return res; } -sexp sexp_make_output_string_port() { +sexp sexp_make_output_string_port () { FILE *out; sexp res, size, cookie; size = sexp_make_integer(SEXP_INIT_STRING_PORT_SIZE); @@ -492,7 +491,7 @@ sexp sexp_make_output_string_port() { return res; } -sexp sexp_get_output_string(sexp port) { +sexp sexp_get_output_string (sexp port) { sexp cookie = sexp_port_cookie(port); fflush(sexp_port_stream(port)); return sexp_substring(sexp_stream_buf(cookie), @@ -502,16 +501,33 @@ sexp sexp_get_output_string(sexp port) { #else -sexp sexp_make_input_string_port(sexp str) { +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 () { + FILE *out; + sexp buf = sexp_alloc_type(string, SEXP_STRING), res; + out = open_memstream(&sexp_string_data(str), &sexp_string_length(buf)); + res = sexp_make_input_port(in); + sexp_port_cookie(res) = buf; + return res; +} + +sexp sexp_get_output_string (sexp port) { + sexp cookie = sexp_port_cookie(port); + fflush(sexp_port_stream(port)); + return sexp_substring(cookie, + sexp_make_integer(0), + sexp_string_length(cookie)); +} + #endif #endif -sexp sexp_make_input_port(FILE* in) { +sexp sexp_make_input_port (FILE* in) { sexp p = sexp_alloc_type(port, SEXP_IPORT); sexp_port_stream(p) = in; sexp_port_name(p) = NULL; @@ -519,7 +535,7 @@ sexp sexp_make_input_port(FILE* in) { return p; } -sexp sexp_make_output_port(FILE* out) { +sexp sexp_make_output_port (FILE* out) { sexp p = sexp_alloc_type(port, SEXP_OPORT); sexp_port_stream(p) = out; sexp_port_name(p) = NULL; @@ -1015,6 +1031,7 @@ sexp sexp_read (sexp in) { return res; } +#if USE_STRING_STREAMS sexp sexp_read_from_string(char *str) { sexp s = sexp_c_string(str); sexp in = sexp_make_input_string_port(s); @@ -1023,6 +1040,7 @@ sexp sexp_read_from_string(char *str) { sexp_deep_free(in); return res; } +#endif void sexp_init() { int i; From 636502de732d7131491da0ff095bd0009ab31171 Mon Sep 17 00:00:00 2001 From: foof Date: Thu, 2 Apr 2009 13:28:31 -0400 Subject: [PATCH 088/154] fixing to work on linux --- Makefile | 3 ++- sexp.c | 4 ++-- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/Makefile b/Makefile index e27b1793..4224566f 100644 --- a/Makefile +++ b/Makefile @@ -10,6 +10,7 @@ INCDIR=$(PREFIX)/include/chibi-scheme MODDIR=$(PREFIX)/share/chibi-scheme SO=.dylib +LDFLAGS=-lm CFLAGS=-Wall -g -save-temps -Os GC_OBJ=./gc/gc.a @@ -33,7 +34,7 @@ libchibischeme.$(SO): eval.o $(GC_OBJ) gcc $(LDFLAGS) -shared -dynamiclib -o $@ $^ -lchibisexp chibi-scheme: main.o sexp.o $(GC_OBJ) - gcc $(CFLAGS) -o $@ $^ + gcc $(CFLAGS) $(LDFLAGS) -o $@ $^ clean: rm -f *.o *.i *.s diff --git a/sexp.c b/sexp.c index b8974b93..1599c089 100644 --- a/sexp.c +++ b/sexp.c @@ -509,8 +509,8 @@ sexp sexp_make_input_string_port (sexp str) { sexp sexp_make_output_string_port () { FILE *out; sexp buf = sexp_alloc_type(string, SEXP_STRING), res; - out = open_memstream(&sexp_string_data(str), &sexp_string_length(buf)); - res = sexp_make_input_port(in); + out = open_memstream(&sexp_string_data(buf), &sexp_string_length(buf)); + res = sexp_make_input_port(out); sexp_port_cookie(res) = buf; return res; } From 55841679e8de6449b55af9161521107d7ed5824f Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Fri, 3 Apr 2009 17:58:03 +0900 Subject: [PATCH 089/154] detecting undefined variables --- debug.c | 7 +++-- eval.c | 82 +++++++++++++++++++++++++++++++------------------------ eval.h | 2 ++ main.c | 6 ++-- opcodes.c | 2 +- sexp.c | 16 +++++------ sexp.h | 6 ++-- 7 files changed, 69 insertions(+), 52 deletions(-) diff --git a/debug.c b/debug.c index 4ff6d2cd..8e0936fa 100644 --- a/debug.c +++ b/debug.c @@ -5,7 +5,8 @@ static const char* reverse_opcode_names[] = {"NOOP", "ERROR", "RESUMECC", "CALLCC", "APPLY1", "TAIL-CALL", "CALL", "FCALL0", "FCALL1", "FCALL2", "FCALL3", "FCALL4", "EVAL", "JUMP-UNLESS", - "JUMP", "PUSH", "DROP", "STACK-REF", "LOCAL-REF", "LOCAL-SET", + "JUMP", "PUSH", "DROP", "GLOBAL-REF", "GLOBAL-KNOWN-REF", "STACK-REF", + "LOCAL-REF", "LOCAL-SET", "CLOSURE-REF", "VECTOR-REF", "VECTOR-SET", "VECTOR-LENGTH", "STRING-REF", "STRING-SET", "STRING-LENGTH", "MAKE-PROCEDURE", "MAKE-VECTOR", "AND", "NULL?", "FIXNUM?", "SYMBOL?", "CHAR?", @@ -45,6 +46,8 @@ static sexp sexp_disasm (sexp bc, sexp out) { sexp_printf(out, "%ld", (sexp_sint_t) ((sexp*)ip)[0]); ip += sizeof(sexp); break; + case OP_GLOBAL_REF: + case OP_GLOBAL_KNOWN_REF: case OP_TAIL_CALL: case OP_CALL: case OP_PUSH: @@ -55,7 +58,7 @@ static sexp sexp_disasm (sexp bc, sexp out) { sexp_write_char('\n', out); if (ip - sexp_bytecode_data(bc) < sexp_bytecode_length(bc)) goto loop; - return SEXP_UNDEF; + return SEXP_VOID; } static void print_bytecode (sexp bc) { diff --git a/eval.c b/eval.c index 3e664860..f3bbfe2a 100644 --- a/eval.c +++ b/eval.c @@ -307,7 +307,7 @@ static sexp analyze_app (sexp x, sexp context) { static sexp analyze_seq (sexp ls, sexp context) { sexp res, tmp; if (sexp_nullp(ls)) - res = SEXP_UNDEF; + res = SEXP_VOID; else if (sexp_nullp(sexp_cdr(ls))) res = analyze(sexp_car(ls), context); else { @@ -369,7 +369,7 @@ static sexp analyze_lambda (sexp x, sexp context) { tmp = sexp_car(ls); if (sexp_pairp(sexp_cadr(tmp))) { name = sexp_caadr(tmp); - value = analyze_lambda(sexp_cons(SEXP_UNDEF, sexp_cons(sexp_cdadr(tmp), + value = analyze_lambda(sexp_cons(SEXP_VOID, sexp_cons(sexp_cdadr(tmp), sexp_cddr(tmp))), context); } else { @@ -395,7 +395,7 @@ static sexp analyze_if (sexp x, sexp context) { sexp test, pass, fail, fail_expr; analyze_bind(test, sexp_cadr(x), context); analyze_bind(pass, sexp_caddr(x), context); - fail_expr = sexp_pairp(sexp_cdddr(x)) ? sexp_cadddr(x) : SEXP_UNDEF; + fail_expr = sexp_pairp(sexp_cdddr(x)) ? sexp_cadddr(x) : SEXP_VOID; analyze_bind(fail, fail_expr, context); return sexp_make_cnd(test, pass, fail); } @@ -409,12 +409,12 @@ static sexp analyze_define (sexp x, sexp context) { sexp_push(sexp_lambda_sv(sexp_env_lambda(env)), name); sexp_push(sexp_lambda_locals(sexp_env_lambda(env)), name); sexp_push(sexp_lambda_defs(sexp_env_lambda(env)), x); - return SEXP_UNDEF; + return SEXP_VOID; } else { - env_cell_create(env, name, SEXP_DEF); + env_cell_create(env, name, SEXP_VOID); } if (sexp_pairp(sexp_cadr(x))) - value = analyze_lambda(sexp_cons(SEXP_UNDEF, + value = analyze_lambda(sexp_cons(SEXP_VOID, sexp_cons(sexp_cdadr(x), sexp_cddr(x))), context); else @@ -431,9 +431,9 @@ static sexp analyze_define_syntax (sexp x, sexp context) { return sexp_compile_error("non-top-level define-syntax", sexp_list1(x)); proc = eval_in_context(sexp_caddr(x), context); analyze_check_exception(proc); - cell = env_cell_create(sexp_context_env(context), name, SEXP_UNDEF); + cell = env_cell_create(sexp_context_env(context), name, SEXP_VOID); sexp_cdr(cell) = sexp_make_macro(proc, sexp_context_env(context)); - return SEXP_UNDEF; + return SEXP_VOID; } static sexp analyze_bind_syntax (sexp ls, sexp eval_ctx, sexp bind_ctx) { @@ -445,7 +445,7 @@ static sexp analyze_bind_syntax (sexp ls, sexp eval_ctx, sexp bind_ctx) { sexp_cons(sexp_caar(ls), sexp_make_macro(proc, sexp_context_env(eval_ctx)))); } - return SEXP_UNDEF; + return SEXP_VOID; } static sexp analyze_let_syntax (sexp x, sexp context) { @@ -623,9 +623,13 @@ static void generate_ref (sexp ref, sexp context, int unboxp) { sexp lam; if (! sexp_lambdap(sexp_ref_loc(ref))) { /* global ref */ - emit_push(sexp_ref_cell(ref), context); - if (unboxp) - emit(OP_CDR, context); + if (unboxp) { + emit((sexp_cdr(sexp_ref_cell(ref)) == SEXP_UNDEF) + ? OP_GLOBAL_REF : OP_GLOBAL_KNOWN_REF, + context); + emit_word((sexp_uint_t)sexp_ref_cell(ref), context); + } else + emit_push(sexp_ref_cell(ref), context); } else { lam = sexp_context_lambda(context); generate_non_global_ref(sexp_ref_name(ref), sexp_ref_cell(ref), lam, @@ -769,7 +773,7 @@ static void generate_lambda (sexp lambda, sexp context) { sexp_context_lambda(ctx) = lambda; /* allocate space for local vars */ for (ls=sexp_lambda_locals(lambda); sexp_pairp(ls); ls=sexp_cdr(ls)) - emit_push(SEXP_UNDEF, ctx); + emit_push(SEXP_VOID, ctx); /* box mutable vars */ for (ls=sexp_lambda_sv(lambda); sexp_pairp(ls); ls=sexp_cdr(ls)) { k = sexp_param_index(lambda, sexp_car(ls)); @@ -790,11 +794,11 @@ static void generate_lambda (sexp lambda, sexp context) { bc = finalize_bytecode(ctx); if (sexp_nullp(fv)) { /* shortcut, no free vars */ - vec = sexp_make_vector(sexp_make_integer(0), SEXP_UNDEF); + vec = sexp_make_vector(sexp_make_integer(0), SEXP_VOID); generate_lit(sexp_make_procedure(flags, len, bc, vec), context); } else { /* push the closed vars */ - emit_push(SEXP_UNDEF, context); + emit_push(SEXP_VOID, context); emit_push(sexp_length(fv), context); emit(OP_MAKE_VECTOR, context); sexp_context_depth(context)--; @@ -934,7 +938,7 @@ static sexp make_opcode_procedure (sexp op, sexp_uint_t i, sexp env, res = sexp_make_procedure(sexp_make_integer(0), sexp_make_integer(i), bc, - SEXP_UNDEF); + SEXP_VOID); if (i == sexp_opcode_num_args(op)) sexp_opcode_proc(op) = res; return res; @@ -945,7 +949,7 @@ static sexp make_opcode_procedure (sexp op, sexp_uint_t i, sexp env, static sexp sexp_save_stack(sexp *stack, sexp_uint_t to) { sexp res, *data; sexp_uint_t i; - res = sexp_make_vector(sexp_make_integer(to), SEXP_UNDEF); + res = sexp_make_vector(sexp_make_integer(to), SEXP_VOID); data = sexp_vector_data(res); for (i=0; i=", 0, NULL), _OP(OPC_ARITHMETIC_CMP, OP_EQN, 0, 1, SEXP_FIXNUM, 0, 0, "=", 0, NULL), _OP(OPC_PREDICATE, OP_EQ, 2, 0, 0, 0, 0, "eq?", 0, NULL), _OP(OPC_CONSTRUCTOR, OP_CONS, 2, 0, 0, 0, 0, "cons", 0, NULL), -_OP(OPC_CONSTRUCTOR, OP_MAKE_VECTOR, 1, 1, SEXP_FIXNUM, 0, 0, "make-vector", SEXP_UNDEF, NULL), +_OP(OPC_CONSTRUCTOR, OP_MAKE_VECTOR, 1, 1, SEXP_FIXNUM, 0, 0, "make-vector", SEXP_VOID, NULL), _OP(OPC_CONSTRUCTOR, OP_MAKE_PROCEDURE, 4, 0, 0, 0, 0, "make-procedure", 0, NULL), _OP(OPC_TYPE_PREDICATE, OP_NULLP, 1, 0, 0, 0, 0, "null?", 0, NULL), _OP(OPC_TYPE_PREDICATE, OP_EOFP, 1, 0, 0, 0, 0, "eof-object?", 0, NULL), diff --git a/sexp.c b/sexp.c index 1599c089..75c8e512 100644 --- a/sexp.c +++ b/sexp.c @@ -147,7 +147,7 @@ sexp sexp_print_exception (sexp exn, sexp out) { } else { sexp_write_string("\n", out); } - return SEXP_UNDEF; + return SEXP_VOID; } static sexp sexp_read_error (char *message, sexp irritants, sexp port) { @@ -296,7 +296,7 @@ sexp sexp_make_string(sexp len, sexp ch) { sexp sexp_c_string(char *str) { sexp_uint_t len = strlen(str); - sexp s = sexp_make_string(sexp_make_integer(len), SEXP_UNDEF); + sexp s = sexp_make_string(sexp_make_integer(len), SEXP_VOID); memcpy(sexp_string_data(s), str, len); return s; } @@ -318,7 +318,7 @@ sexp sexp_substring (sexp str, sexp start, sexp end) { || (end < start)) return sexp_range_exception(str, start, end); res = sexp_make_string(sexp_fx_sub(end, start), - SEXP_UNDEF); + SEXP_VOID); memcpy(sexp_string_data(res), sexp_string_data(str)+sexp_unbox_integer(start), sexp_string_length(res)); @@ -393,7 +393,7 @@ sexp sexp_make_vector(sexp len, sexp dflt) { } sexp sexp_list_to_vector(sexp ls) { - sexp x, vec = sexp_make_vector(sexp_length(ls), SEXP_UNDEF); + sexp x, vec = sexp_make_vector(sexp_length(ls), SEXP_VOID); sexp *elts = sexp_vector_data(vec); int i; for (i=0, x=ls; sexp_pairp(x); i++, x=sexp_cdr(x)) @@ -402,7 +402,7 @@ sexp sexp_list_to_vector(sexp ls) { } sexp sexp_vector(int count, ...) { - sexp vec = sexp_make_vector(sexp_make_integer(count), SEXP_UNDEF); + sexp vec = sexp_make_vector(sexp_make_integer(count), SEXP_VOID); sexp *elts = sexp_vector_data(vec); va_list ap; int i; @@ -443,7 +443,7 @@ int sstream_write (void *vec, const char *src, int n) { pos = sexp_unbox_integer(sexp_stream_pos(vec)); newpos = pos+n; if (newpos > len) { - newbuf = sexp_make_string(sexp_make_integer(len*2), SEXP_UNDEF); + newbuf = sexp_make_string(sexp_make_integer(len*2), SEXP_VOID); memcpy(sexp_string_data(newbuf), sexp_string_data(sexp_stream_buf(vec)), pos); @@ -483,7 +483,7 @@ sexp sexp_make_output_string_port () { FILE *out; sexp res, size, cookie; size = sexp_make_integer(SEXP_INIT_STRING_PORT_SIZE); - cookie = sexp_vector(3, sexp_make_string(size, SEXP_UNDEF), + cookie = sexp_vector(3, sexp_make_string(size, SEXP_VOID), size, sexp_make_integer(0)); out = funopen(cookie, NULL, &sstream_write, &sstream_seek, NULL); res = sexp_make_output_port(out); @@ -708,8 +708,8 @@ void sexp_write (sexp obj, sexp out) { sexp_write_string("#f", out); break; case (sexp_uint_t) SEXP_EOF: sexp_write_string("#", out); break; - case (sexp_uint_t) SEXP_DEF: case (sexp_uint_t) SEXP_UNDEF: + case (sexp_uint_t) SEXP_VOID: sexp_write_string("#", out); break; case (sexp_uint_t) SEXP_ERROR: sexp_write_string("#", out); break; diff --git a/sexp.h b/sexp.h index 5c70840b..4dc7cd9a 100644 --- a/sexp.h +++ b/sexp.h @@ -177,9 +177,9 @@ struct sexp_struct { #define SEXP_FALSE SEXP_MAKE_IMMEDIATE(1) #define SEXP_TRUE SEXP_MAKE_IMMEDIATE(2) #define SEXP_EOF SEXP_MAKE_IMMEDIATE(3) -#define SEXP_UNDEF SEXP_MAKE_IMMEDIATE(4) -#define SEXP_ERROR SEXP_MAKE_IMMEDIATE(5) /* exceptions are preferred */ -#define SEXP_DEF SEXP_MAKE_IMMEDIATE(6) /* internal use */ +#define SEXP_VOID SEXP_MAKE_IMMEDIATE(4) +#define SEXP_ERROR SEXP_MAKE_IMMEDIATE(5) /* internal use */ +#define SEXP_UNDEF SEXP_MAKE_IMMEDIATE(6) /* internal use */ #define SEXP_CLOSE SEXP_MAKE_IMMEDIATE(7) /* internal use */ #define SEXP_RAWDOT SEXP_MAKE_IMMEDIATE(8) /* internal use */ From d33c766823ce49d76bddf4e306534f46ea7d754f Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Fri, 3 Apr 2009 19:02:29 +0900 Subject: [PATCH 090/154] fixing parameter separation between environments --- eval.c | 16 ++++++++++------ main.c | 10 +++++++--- sexp.c | 2 +- 3 files changed, 18 insertions(+), 10 deletions(-) diff --git a/eval.c b/eval.c index f3bbfe2a..81acf47b 100644 --- a/eval.c +++ b/eval.c @@ -721,6 +721,7 @@ static void generate_opcode_app (sexp app, sexp context) { case OPC_PARAMETER: emit_push(sexp_opcode_default(op), context); emit((num_args == 0 ? OP_CDR : OP_SET_CDR), context); + break; default: emit(sexp_opcode_code(op), context); } @@ -1515,6 +1516,7 @@ sexp sexp_close_port (sexp port) { sexp sexp_load (sexp source, sexp env) { sexp obj, res, in, context = sexp_make_context(NULL, env); + sexp_context_tailp(context) = 0; in = sexp_open_input_file(source); while ((obj=sexp_read(in)) != (sexp) SEXP_EOF) { res = eval_in_context(obj, context); @@ -1648,8 +1650,6 @@ static struct sexp_struct core_forms[] = { #include "opcodes.c" -static int standard_env_syms_interned_p = 0; - static sexp sexp_make_null_env (sexp version) { sexp_uint_t i; sexp e = sexp_alloc_type(env, SEXP_ENV); @@ -1660,14 +1660,19 @@ static sexp sexp_make_null_env (sexp version) { return e; } +static sexp sexp_copy_opcode (sexp op) { + sexp res = sexp_alloc_type(opcode, SEXP_OPCODE); + memcpy(res, op, sexp_sizeof(opcode)); + return res; +} + static sexp sexp_make_standard_env (sexp version) { sexp_uint_t i; sexp e = sexp_make_null_env(version), op, cell, sym; for (i=0; i<(sizeof(opcodes)/sizeof(opcodes[0])); i++) { op = &opcodes[i]; - if ((! standard_env_syms_interned_p) - && sexp_opcode_opt_param_p(op) - && sexp_opcode_default(op)) { + if (sexp_opcode_opt_param_p(op) && sexp_opcode_default(op)) { + op = sexp_copy_opcode(op); sym = sexp_intern((char*)sexp_opcode_default(op)); cell = env_cell_create(e, sym, SEXP_VOID); sexp_opcode_default(op) = cell; @@ -1678,7 +1683,6 @@ static sexp sexp_make_standard_env (sexp version) { env_define(e, the_cur_out_symbol, sexp_make_output_port(stdout)); env_define(e, the_cur_err_symbol, sexp_make_output_port(stderr)); env_define(e, the_interaction_env_symbol, e); - standard_env_syms_interned_p = 1; return e; } diff --git a/main.c b/main.c index 75dac536..938d2918 100644 --- a/main.c +++ b/main.c @@ -30,6 +30,7 @@ void run_main (int argc, char **argv) { sexp_uint_t i, quit=0, init_loaded=0; env = sexp_make_standard_env(sexp_make_integer(5)); + env_define(env, the_interaction_env_symbol, env); context = sexp_make_context(NULL, env); sexp_context_tailp(context) = 0; emit_push(SEXP_VOID, context); @@ -46,10 +47,8 @@ void run_main (int argc, char **argv) { #if USE_STRING_STREAMS case 'e': case 'p': - if (! init_loaded) { + if (! init_loaded++) sexp_load(sexp_c_string(sexp_init_file), env); - init_loaded = 1; - } obj = sexp_read_from_string(argv[i+1]); res = eval_in_context(obj, context); if (argv[i][1] == 'p') { @@ -62,6 +61,11 @@ void run_main (int argc, char **argv) { i++; break; #endif + case 'l': + if (! init_loaded++) + sexp_load(sexp_c_string(sexp_init_file), env); + sexp_load(sexp_c_string(argv[++i]), env); + break; case 'q': init_loaded = 1; break; diff --git a/sexp.c b/sexp.c index 75c8e512..688f6938 100644 --- a/sexp.c +++ b/sexp.c @@ -599,7 +599,7 @@ void sexp_write (sexp obj, sexp out) { case SEXP_BYTECODE: sexp_write_string("#", out); break; case SEXP_ENV: - sexp_write_string("#", out); break; + sexp_printf(out, "#", obj); break; case SEXP_EXCEPTION: sexp_write_string("#", out); break; case SEXP_MACRO: From b207ef5604711886457e737fde1f497ef9ca9976 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Fri, 3 Apr 2009 19:11:57 +0900 Subject: [PATCH 091/154] top-level isn't a tail-call --- eval.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/eval.c b/eval.c index 81acf47b..b0fa610d 100644 --- a/eval.c +++ b/eval.c @@ -241,7 +241,7 @@ static sexp sexp_make_context(sexp *stack, sexp env) { sexp_context_depth(res) = 0; sexp_context_pos(res) = 0; sexp_context_top(res) = 0; - sexp_context_tailp(res) = 1; + sexp_context_tailp(res) = 0; return res; } @@ -788,6 +788,7 @@ static void generate_lambda (sexp lambda, sexp context) { emit(OP_DROP, ctx); } } + sexp_context_tailp(ctx) = 1; generate(sexp_lambda_body(lambda), ctx); flags = sexp_make_integer((sexp_listp(sexp_lambda_params(lambda))==SEXP_FALSE) ? 1 : 0); From ca9e391ee31d899142e7d39826abbf87cc42cdfa Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Fri, 3 Apr 2009 23:27:01 +0900 Subject: [PATCH 092/154] fixing tail-call bug when the new frame is larger. allowing (error x) for any object x. vm tracing is now a compile-time option with -DDEBUG_VM. --- Makefile | 6 ++--- debug.c | 27 +---------------------- eval.c | 14 +++++++++--- main.c | 1 + sexp.c | 57 ++++++++++++++++++++++++++++-------------------- sexp.h | 3 ++- syntax-rules.scm | 2 +- 7 files changed, 52 insertions(+), 58 deletions(-) diff --git a/Makefile b/Makefile index 4224566f..eac74288 100644 --- a/Makefile +++ b/Makefile @@ -19,13 +19,13 @@ GC_OBJ=./gc/gc.a cd gc && make test sexp.o: sexp.c sexp.h config.h defaults.h Makefile - gcc -c $(CFLAGS) -o $@ $< + gcc -c $(CPPFLAGS) $(CFLAGS) -o $@ $< eval.o: eval.c debug.c opcodes.c eval.h sexp.h config.h defaults.h Makefile - gcc -c $(CFLAGS) -o $@ $< + gcc -c $(CPPFLAGS) $(CFLAGS) -o $@ $< main.o: main.c eval.c debug.c opcodes.c eval.h sexp.h config.h defaults.h Makefile - gcc -c $(CFLAGS) -o $@ $< + gcc -c $(CPPFLAGS) $(CFLAGS) -o $@ $< libchibisexp.$(SO): sexp.o $(GC_OBJ) gcc $(LDFLAGS) -shared -dynamiclib -o $@ $^ diff --git a/debug.c b/debug.c index 8e0936fa..299b20cc 100644 --- a/debug.c +++ b/debug.c @@ -61,32 +61,7 @@ static sexp sexp_disasm (sexp bc, sexp out) { return SEXP_VOID; } -static void print_bytecode (sexp bc) { - int i; - unsigned char *data = sexp_bytecode_data(bc); - fprintf(stderr, "bytecode @ %p, data @ %p, length = %lu\n", - bc, data, sexp_bytecode_length(bc)); - for (i=0; i+16 < sexp_bytecode_length(bc); i+=8) { - fprintf(stderr, "%02x: %02x %02x %02x %02x %02x %02x %02x %02x ", i, - data[i], data[i+1], data[i+2], data[i+3], - data[i+4], data[i+5], data[i+6], data[i+7]); - i += 8; - fprintf(stderr, "%02x %02x %02x %02x %02x %02x %02x %02x\n", - data[i], data[i+1], data[i+2], data[i+3], - data[i+4], data[i+5], data[i+6], data[i+7]); - } - if (i != sexp_bytecode_length(bc)) { - fprintf(stderr, "%02x:", i); - for ( ; i < sexp_bytecode_length(bc); i++) { - if ((i % 8) == 0 && (i % 16) != 0) - fprintf(stderr, " "); - fprintf(stderr, " %02x", data[i]); - } - fprintf(stderr, "\n"); - } -} - -static void print_stack (sexp *stack, int top, int fp, sexp out) { +static void sexp_print_stack (sexp *stack, int top, int fp, sexp out) { int i; for (i=0; i>>\n"); @@ -1050,6 +1057,7 @@ sexp vm(sexp bc, sexp cp, sexp context, sexp* stack, sexp_sint_t top) { i = sexp_unbox_integer(_WORD0); /* number of params */ tmp1 = _ARG1; /* procedure to call */ /* save frame info */ + tmp2 = stack[fp+3]; j = sexp_unbox_integer(stack[fp]); ip = ((unsigned char*) sexp_unbox_integer(stack[fp+1])) - sizeof(sexp); cp = stack[fp+2]; @@ -1057,7 +1065,7 @@ sexp vm(sexp bc, sexp cp, sexp context, sexp* stack, sexp_sint_t top) { for (k=0; k= INIT_STACK_SIZE) diff --git a/main.c b/main.c index 938d2918..1b14ee97 100644 --- a/main.c +++ b/main.c @@ -4,6 +4,7 @@ void repl (sexp context) { sexp obj, res, env, in, out, err; env = sexp_context_env(context); + sexp_context_tracep(context) = 1; in = env_global_ref(env, the_cur_in_symbol, SEXP_FALSE); out = env_global_ref(env, the_cur_out_symbol, SEXP_FALSE); err = env_global_ref(env, the_cur_err_symbol, SEXP_FALSE); diff --git a/sexp.c b/sexp.c index 688f6938..531f1b32 100644 --- a/sexp.c +++ b/sexp.c @@ -118,34 +118,43 @@ sexp sexp_range_exception (sexp obj, sexp start, sexp end) { 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_exception_irritants(exn) - && 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); + if (sexp_exceptionp(exn)) { + 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_exception_irritants(exn) + && 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_char('\n', out); + } } + } else { + sexp_write_char('\n', out); } } else { - sexp_write_string("\n", out); + sexp_write_string(": ", out); + if (sexp_stringp(exn)) + sexp_write_string(sexp_string_data(exn), out); + else + sexp_write(exn, out); + sexp_write_char('\n', out); } return SEXP_VOID; } diff --git a/sexp.h b/sexp.h index 4dc7cd9a..9784795f 100644 --- a/sexp.h +++ b/sexp.h @@ -160,7 +160,7 @@ struct sexp_struct { /* compiler state */ struct { sexp bc, lambda, *stack, env; - sexp_uint_t pos, top, depth, tailp; + sexp_uint_t pos, top, depth, tailp, tracep; } context; } value; }; @@ -340,6 +340,7 @@ struct sexp_struct { #define sexp_context_top(x) ((x)->value.context.top) #define sexp_context_lambda(x) ((x)->value.context.lambda) #define sexp_context_tailp(x) ((x)->value.context.tailp) +#define sexp_context_tracep(x) ((x)->value.context.tailp) /****************************** arithmetic ****************************/ diff --git a/syntax-rules.scm b/syntax-rules.scm index 2433718e..f323a979 100644 --- a/syntax-rules.scm +++ b/syntax-rules.scm @@ -168,7 +168,7 @@ (map (lambda (clause) (expand-pattern (car clause) (cadr clause))) forms) - (list (list 'else) (list 'error "no expansion")))))))))) + (list (list 'error "no expansion")))))))))) ;; Local Variables: ;; eval: (put '_lambda 'scheme-indent-function 1) From 78de2d139402f4f2449cc3ee13b1cc7dd280ac5a Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Fri, 3 Apr 2009 23:53:18 +0900 Subject: [PATCH 093/154] fixing bug in cond with => patterns --- init.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/init.scm b/init.scm index 16e8a236..6773cb03 100644 --- a/init.scm +++ b/init.scm @@ -157,7 +157,8 @@ (list (rename 'if) (rename 'tmp) (if (null? (cdr cl)) (rename 'tmp) - (list (caddr cl) (rename 'tmp))))) + (list (caddr cl) (rename 'tmp))) + (cons (rename 'cond) (cddr expr)))) (list (rename 'if) (car cl) (cons (rename 'begin) (cdr cl)) From 3f98dd503584b73352163c353c13151fda4f607c Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 4 Apr 2009 00:02:02 +0900 Subject: [PATCH 094/154] need to quote literals in syntax-rules --- syntax-rules.scm | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/syntax-rules.scm b/syntax-rules.scm index f323a979..73ef04ef 100644 --- a/syntax-rules.scm +++ b/syntax-rules.scm @@ -36,7 +36,7 @@ _let (list (list v x)) (cond ((symbol? p) - (if (memq p lits) + (if (memq p (list _quote lits)) (list _and (list _eq? v p) (k vars)) (list _let (list (list p v)) (k (cons (cons p dim) vars))))) ((ellipse? p) @@ -104,7 +104,9 @@ (cdr x))) (define (all-vars x dim) (let lp ((x x) (dim dim) (vars '())) - (cond ((symbol? x) (if (memq x lits) vars (cons (cons x dim) vars))) + (cond ((symbol? x) (if (memq x (list _quote lits)) + vars + (cons (cons x dim) vars))) ((ellipse? x) (lp (car x) (+ dim 1) vars)) ((pair? x) (lp (car x) dim (lp (cdr x) dim vars))) ((vector? x) (lp (vector->list x) dim vars)) From fad4e3976e001a8fadc1302702b0db8c4e0e42fb Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Wed, 8 Apr 2009 10:16:26 +0900 Subject: [PATCH 095/154] r5rs test suite, various bugfixes --- Makefile | 2 +- config.h | 3 + defaults.h | 4 + eval.c | 56 ++- init.scm | 71 ++-- main.c | 6 +- opcodes.c | 3 +- sexp.c | 128 +++++-- sexp.h | 6 +- tests/{ => basic}/test00-fact-3.res | 0 tests/{ => basic}/test00-fact-3.scm | 0 tests/{ => basic}/test01-apply.res | 0 tests/{ => basic}/test01-apply.scm | 0 tests/{ => basic}/test02-closure.res | 0 tests/{ => basic}/test02-closure.scm | 0 tests/{ => basic}/test03-nested-closure.res | 0 tests/{ => basic}/test03-nested-closure.scm | 0 tests/{ => basic}/test04-nested-let.res | 0 tests/{ => basic}/test04-nested-let.scm | 0 tests/{ => basic}/test05-internal-define.res | 0 tests/{ => basic}/test05-internal-define.scm | 0 tests/{ => basic}/test06-letrec.res | 0 tests/{ => basic}/test06-letrec.scm | 0 tests/{ => basic}/test07-mutation.res | 0 tests/{ => basic}/test07-mutation.scm | 0 tests/{ => basic}/test08-callcc.res | 0 tests/{ => basic}/test08-callcc.scm | 0 tests/{ => basic}/test09-hygiene.res | 0 tests/{ => basic}/test09-hygiene.scm | 0 tests/r5rs-tests.scm | 372 +++++++++++++++++++ 30 files changed, 560 insertions(+), 91 deletions(-) rename tests/{ => basic}/test00-fact-3.res (100%) rename tests/{ => basic}/test00-fact-3.scm (100%) rename tests/{ => basic}/test01-apply.res (100%) rename tests/{ => basic}/test01-apply.scm (100%) rename tests/{ => basic}/test02-closure.res (100%) rename tests/{ => basic}/test02-closure.scm (100%) rename tests/{ => basic}/test03-nested-closure.res (100%) rename tests/{ => basic}/test03-nested-closure.scm (100%) rename tests/{ => basic}/test04-nested-let.res (100%) rename tests/{ => basic}/test04-nested-let.scm (100%) rename tests/{ => basic}/test05-internal-define.res (100%) rename tests/{ => basic}/test05-internal-define.scm (100%) rename tests/{ => basic}/test06-letrec.res (100%) rename tests/{ => basic}/test06-letrec.scm (100%) rename tests/{ => basic}/test07-mutation.res (100%) rename tests/{ => basic}/test07-mutation.scm (100%) rename tests/{ => basic}/test08-callcc.res (100%) rename tests/{ => basic}/test08-callcc.scm (100%) rename tests/{ => basic}/test09-hygiene.res (100%) rename tests/{ => basic}/test09-hygiene.scm (100%) create mode 100644 tests/r5rs-tests.scm diff --git a/Makefile b/Makefile index eac74288..10333b68 100644 --- a/Makefile +++ b/Makefile @@ -44,7 +44,7 @@ cleaner: clean rm -rf *.dSYM test: chibi-scheme - @for f in tests/*.scm; do \ + @for f in tests/basic/*.scm; do \ ./chibi-scheme $$f >$${f%.scm}.out 2>$${f%.scm}.err; \ if diff -q $${f%.scm}.out $${f%.scm}.res; then \ echo "[PASS] $${f%.scm}"; \ diff --git a/config.h b/config.h index cf480383..81f1444c 100644 --- a/config.h +++ b/config.h @@ -11,6 +11,9 @@ /* uncomment this if you don't need extended math operations */ /* #define USE_MATH 0 */ +/* uncomment this to disable warning about references to undefined variables */ +/* #define USE_WARN_UNDEFS 0 */ + /* uncomment this to disable huffman-coded immediate symbols */ /* #define USE_HUFF_SYMS 0 */ diff --git a/defaults.h b/defaults.h index c463c75e..f2399aff 100644 --- a/defaults.h +++ b/defaults.h @@ -27,6 +27,10 @@ #define USE_MATH 1 #endif +#ifndef USE_WARN_UNDEFS +#define USE_WARN_UNDEFS 1 +#endif + #ifndef USE_HUFF_SYMS #define USE_HUFF_SYMS 1 #endif diff --git a/eval.c b/eval.c index b6541f8b..f41a1a13 100644 --- a/eval.c +++ b/eval.c @@ -689,6 +689,10 @@ static void generate_opcode_app (sexp app, sexp context) { /* emit the actual operator call */ switch (sexp_opcode_class(op)) { + case OPC_ARITHMETIC: + if (num_args > 1) + emit(sexp_opcode_code(op), context); + break; case OPC_ARITHMETIC_INV: emit((num_args == 1) ? sexp_opcode_inverse(op) : sexp_opcode_code(op), context); @@ -1368,7 +1372,7 @@ sexp vm(sexp bc, sexp cp, sexp context, sexp* stack, sexp_sint_t top) { break; case OP_LT: if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) - i = _ARG1 < _ARG2; + i = (sexp_sint_t)_ARG1 < (sexp_sint_t)_ARG2; #if USE_FLONUMS else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) i = sexp_flonum_value(_ARG1) < sexp_flonum_value(_ARG2); @@ -1383,7 +1387,7 @@ sexp vm(sexp bc, sexp cp, sexp context, sexp* stack, sexp_sint_t top) { break; case OP_LE: if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) - i = _ARG1 <= _ARG2; + i = (sexp_sint_t)_ARG1 <= (sexp_sint_t)_ARG2; #if USE_FLONUMS else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) i = sexp_flonum_value(_ARG1) <= sexp_flonum_value(_ARG2); @@ -1510,31 +1514,55 @@ sexp vm(sexp bc, sexp cp, sexp context, sexp* stack, sexp_sint_t top) { /************************ library procedures **************************/ -sexp sexp_open_input_file (sexp path) { - return sexp_make_input_port(fopen(sexp_string_data(path), "r")); +static sexp sexp_open_input_file (sexp path) { + FILE *in; + if (! sexp_stringp(path)) return sexp_type_exception("not a string", path); + in = fopen(sexp_string_data(path), "r"); + if (! in) return sexp_user_exception("couldn't open input file", path); + return sexp_make_input_port(in, sexp_string_data(path)); } -sexp sexp_open_output_file (sexp path) { - return sexp_make_input_port(fopen(sexp_string_data(path), "w")); +static sexp sexp_open_output_file (sexp path) { + FILE *out; + if (! sexp_stringp(path)) return sexp_type_exception("not a string", path); + out = fopen(sexp_string_data(path), "w"); + if (! out) return sexp_user_exception("couldn't open output file", path); + return sexp_make_input_port(out, sexp_string_data(path)); } -sexp sexp_close_port (sexp port) { +static sexp sexp_close_port (sexp port) { fclose(sexp_port_stream(port)); return SEXP_VOID; } +static void sexp_warn_undefs (sexp from, sexp to, sexp out) { + sexp x; + for (x=from; sexp_pairp(x) && x!=to; x=sexp_cdr(x)) + if (sexp_cdar(x) == SEXP_UNDEF) { + sexp_write_string("WARNING: reference to undefined variable: ", out); + sexp_write(sexp_caar(x), out); + sexp_write_char('\n', out); + } +} + sexp sexp_load (sexp source, sexp env) { - sexp obj, res, in, context = sexp_make_context(NULL, env); + sexp x, res, in, tmp, out, context = sexp_make_context(NULL, env); + tmp = sexp_env_bindings(env); sexp_context_tailp(context) = 0; in = sexp_open_input_file(source); - while ((obj=sexp_read(in)) != (sexp) SEXP_EOF) { - res = eval_in_context(obj, context); + while ((x=sexp_read(in)) != (sexp) SEXP_EOF) { + res = eval_in_context(x, context); if (sexp_exceptionp(res)) break; } - if (obj == SEXP_EOF) + if (x == SEXP_EOF) res = SEXP_VOID; sexp_close_port(in); +#ifdef USE_WARN_UNDEFS + out = env_global_ref(env, the_cur_err_symbol, SEXP_FALSE); + if (sexp_oportp(out)) + sexp_warn_undefs(sexp_env_bindings(env), tmp, out); +#endif return res; } @@ -1688,9 +1716,9 @@ static sexp sexp_make_standard_env (sexp version) { } env_define(e, sexp_intern(sexp_opcode_name(op)), op); } - env_define(e, the_cur_in_symbol, sexp_make_input_port(stdin)); - env_define(e, the_cur_out_symbol, sexp_make_output_port(stdout)); - env_define(e, the_cur_err_symbol, sexp_make_output_port(stderr)); + env_define(e, the_cur_in_symbol, sexp_make_input_port(stdin, NULL)); + env_define(e, the_cur_out_symbol, sexp_make_output_port(stdout, NULL)); + env_define(e, the_cur_err_symbol, sexp_make_output_port(stderr, NULL)); env_define(e, the_interaction_env_symbol, e); return e; } diff --git a/init.scm b/init.scm index 6773cb03..17f3ad5d 100644 --- a/init.scm +++ b/init.scm @@ -30,6 +30,10 @@ (define (cdddar x) (cdr (cdr (cdr (car x))))) (define (cddddr x) (cdr (cdr (cdr (cdr x))))) +;; basic utils + +(define (procedure? x) (if (closure? x) #t (opcode? x))) + (define (list . args) args) (define (list-tail ls k) @@ -39,26 +43,6 @@ (define (list-ref ls k) (car (list-tail ls k))) -(define (eqv? a b) (if (eq? a b) #t (and (flonum? a) (flonum? b) (= a b)))) - -(define (member obj ls) - (if (null? ls) - #f - (if (equal? obj (car ls)) - ls - (member obj (cdr ls))))) - -(define memv member) - -(define (assoc obj ls) - (if (null? ls) - #f - (if (equal? obj (caar ls)) - (car ls) - (assoc obj (cdr ls))))) - -(define assv assoc) - (define (append-reverse a b) (if (pair? a) (append-reverse (cdr a) (cons (car a) b)) @@ -175,13 +159,16 @@ ((eq? 'unquote (car x)) (if (<= d 0) (cadr x) - (list (rename 'unquote) (qq (cadr x) (- d 1))))) + (list (rename 'list) (list (rename 'quote) 'unquote) + (qq (cadr x) (- d 1))))) ((eq? 'unquote-splicing (car x)) (if (<= d 0) (list (rename 'cons) (qq (car x) d) (qq (cdr x) d)) - (list (rename 'unquote-splicing) (qq (cadr x) (- d 1))))) + (list (rename 'list) (list (rename 'quote) 'unquote-splicing) + (qq (cadr x) (- d 1))))) ((eq? 'quasiquote (car x)) - (list (rename 'quasiquote) (qq (cadr x) (+ d 1)))) + (list (rename 'list) (list (rename 'quote) 'quasiquote) + (qq (cadr x) (+ d 1)))) ((and (<= d 0) (pair? (car x)) (eq? 'unquote-splicing (caar x))) (if (null? (cdr x)) (cadar x) @@ -264,7 +251,7 @@ (define-syntax delay (er-macro-transformer (lambda (expr rename compare) - `(,(rename 'make-promise) (,(rename 'lambda) () ,(cadr epr)))))) + `(,(rename 'make-promise) (,(rename 'lambda) () ,(cadr expr)))))) (define (make-promise thunk) (lambda () @@ -348,6 +335,28 @@ (define (string-ci>? s1 s2) (> (string-cmp-ci s1 s2) 0)) (define (string-ci>=? s1 s2) (>= (string-cmp-ci s1 s2) 0)) +;; list utils + +(define (eqv? a b) (if (eq? a b) #t (and (flonum? a) (flonum? b) (= a b)))) + +(define (member obj ls) + (if (null? ls) + #f + (if (equal? obj (car ls)) + ls + (member obj (cdr ls))))) + +(define memv member) + +(define (assoc obj ls) + (if (null? ls) + #f + (if (equal? obj (caar ls)) + (car ls) + (assoc obj (cdr ls))))) + +(define assv assoc) + ;; math utils (define (number? x) (if (fixnum? x) #t (flonum? x))) @@ -369,16 +378,16 @@ (define (modulo a b) (let ((res (remainder a b))) (if (< b 0) - (if (< res 0) res (- res b)) - (if (> res 0) res (+ res b))))) + (if (<= res 0) res (+ res b)) + (if (>= res 0) res (+ res b))))) (define (gcd a b) (if (= b 0) - a - (gcd b (modulo a b)))) + (abs a) + (gcd b (remainder a b)))) (define (lcm a b) - (quotient (* a b) (gcd a b))) + (abs (quotient (* a b) (gcd a b)))) (define (max x . rest) (let lp ((hi x) (ls rest)) @@ -468,8 +477,8 @@ (define (call-with-output-file file proc) (let* ((out (open-output-file file)) - (res (proc in))) - (close-output-port in) + (res (proc out))) + (close-output-port out) res)) (define (with-input-from-file file thunk) diff --git a/main.c b/main.c index 1b14ee97..f666c07a 100644 --- a/main.c +++ b/main.c @@ -2,7 +2,7 @@ #include "eval.c" void repl (sexp context) { - sexp obj, res, env, in, out, err; + sexp obj, tmp, res, env, in, out, err; env = sexp_context_env(context); sexp_context_tracep(context) = 1; in = env_global_ref(env, the_cur_in_symbol, SEXP_FALSE); @@ -17,7 +17,11 @@ void repl (sexp context) { if (sexp_exceptionp(obj)) { sexp_print_exception(obj, err); } else { + tmp = sexp_env_bindings(env); res = eval_in_context(obj, context); +#ifdef USE_WARN_UNDEFS + sexp_warn_undefs(sexp_env_bindings(env), tmp, err); +#endif if (res != SEXP_VOID) { sexp_write(res, out); sexp_write_char('\n', out); diff --git a/opcodes.c b/opcodes.c index af18e911..8305cf3f 100644 --- a/opcodes.c +++ b/opcodes.c @@ -52,7 +52,8 @@ _OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "pair?", 0, (sexp)SEXP_PAIR), _OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "string?", 0, (sexp)SEXP_STRING), _OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "vector?", 0, (sexp)SEXP_VECTOR), _OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "flonum?", 0, (sexp)SEXP_FLONUM), -_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "procedure?", 0, (sexp)SEXP_PROCEDURE), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "closure?", 0, (sexp)SEXP_PROCEDURE), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "opcode?", 0, (sexp)SEXP_OPCODE), _OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "input-port?", 0, (sexp)SEXP_IPORT), _OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "output-port?", 0, (sexp)SEXP_OPORT), _OP(OPC_GENERIC, OP_APPLY1, 2, 0, SEXP_PROCEDURE, SEXP_PAIR, 0, "apply1", 0, NULL), diff --git a/sexp.c b/sexp.c index 531f1b32..9708f1fe 100644 --- a/sexp.c +++ b/sexp.c @@ -102,6 +102,14 @@ sexp sexp_make_exception (sexp kind, sexp message, sexp irritants, return exn; } +sexp sexp_user_exception (char *message, sexp irritants) { + return sexp_make_exception(sexp_intern("user-error"), + sexp_c_string(message), + ((sexp_pairp(irritants) || sexp_nullp(irritants)) + ? irritants : sexp_list1(irritants)), + SEXP_FALSE, SEXP_FALSE); +} + sexp sexp_type_exception (char *message, sexp obj) { return sexp_make_exception(sexp_intern("type-error"), sexp_c_string(message), @@ -178,10 +186,18 @@ sexp sexp_cons (sexp head, sexp tail) { return pair; } -sexp sexp_listp (sexp obj) { - while (sexp_pairp(obj)) - obj = sexp_cdr(obj); - return sexp_make_boolean(obj == SEXP_NULL); +sexp sexp_listp (sexp hare) { + sexp turtle; + if (! sexp_pairp(hare)) + return sexp_make_boolean(hare == SEXP_NULL); + turtle = hare; + hare = sexp_cdr(hare); + for ( ; sexp_pairp(hare); turtle=sexp_cdr(turtle)) { + if (hare == turtle) return SEXP_FALSE; + hare = sexp_cdr(hare); + if (sexp_pairp(hare)) hare = sexp_cdr(hare); + } + return sexp_make_boolean(hare == SEXP_NULL); } sexp sexp_memq (sexp x, sexp ls) { @@ -269,7 +285,7 @@ sexp sexp_equalp (sexp a, sexp b) { return SEXP_FALSE; v1 = sexp_vector_data(a); v2 = sexp_vector_data(b); - for (len--; len >= 0; len--) + for (len--; len > 0; len--) if (sexp_equalp(v1[len], v2[len]) == SEXP_FALSE) return SEXP_FALSE; return SEXP_TRUE; @@ -278,6 +294,8 @@ sexp sexp_equalp (sexp a, sexp b) { && (! strncmp(sexp_string_data(a), sexp_string_data(b), sexp_string_length(a)))); + case SEXP_FLONUM: + return sexp_make_boolean(sexp_flonum_value(a) == sexp_flonum_value(b)); default: return SEXP_FALSE; } @@ -292,9 +310,11 @@ sexp sexp_make_flonum(double f) { } sexp sexp_make_string(sexp len, sexp ch) { + char *cstr; sexp s = sexp_alloc_type(string, SEXP_STRING); - sexp_uint_t clen = sexp_unbox_integer(len); - char *cstr = sexp_alloc(clen+1); + sexp_sint_t clen = sexp_unbox_integer(len); + if (clen < 0) return sexp_type_exception("negative length", len); + cstr = sexp_alloc(clen+1); if (sexp_charp(ch)) memset(cstr, sexp_unbox_character(ch), clen); cstr[clen] = '\0'; @@ -441,7 +461,7 @@ int sstream_read (void *vec, char *dst, int n) { if (pos >= len) return 0; if (n > (len - pos)) n = (len - pos); memcpy(dst, sexp_string_data(sexp_stream_buf(vec))+pos, n); - sexp_vector_set((sexp) vec, sexp_make_integer(2), sexp_make_integer(n)); + sexp_stream_pos(vec) = sexp_make_integer(n); return n; } @@ -451,16 +471,16 @@ int sstream_write (void *vec, const char *src, int n) { len = sexp_unbox_integer(sexp_stream_size(vec)); pos = sexp_unbox_integer(sexp_stream_pos(vec)); newpos = pos+n; - if (newpos > len) { - newbuf = sexp_make_string(sexp_make_integer(len*2), SEXP_VOID); + if (newpos >= len) { + newbuf = sexp_make_string(sexp_make_integer(newpos*2), SEXP_VOID); memcpy(sexp_string_data(newbuf), sexp_string_data(sexp_stream_buf(vec)), pos); - sexp_vector_set((sexp)vec, sexp_make_integer(0), newbuf); - sexp_vector_set((sexp)vec, sexp_make_integer(1), sexp_make_integer(len*2)); + sexp_stream_buf(vec) = newbuf; + sexp_stream_size(vec) = sexp_make_integer(newpos*2); } memcpy(sexp_string_data(sexp_stream_buf(vec))+pos, src, n); - sexp_vector_set((sexp)vec, sexp_make_integer(2), sexp_make_integer(newpos)); + sexp_stream_pos(vec) = sexp_make_integer(newpos); return n; } @@ -473,7 +493,7 @@ off_t sstream_seek (void *vec, off_t offset, int whence) { } else { /* SEEK_END */ pos = sexp_unbox_integer(sexp_stream_size(vec)) + offset; } - sexp_vector_set((sexp)vec, sexp_make_integer(2), sexp_make_integer(pos)); + sexp_stream_pos(vec) = sexp_make_integer(pos); return pos; } @@ -483,7 +503,7 @@ sexp sexp_make_input_string_port (sexp str) { cookie = sexp_vector(3, str, sexp_make_integer(sexp_string_length(str)), sexp_make_integer(0)); in = funopen(cookie, &sstream_read, NULL, &sstream_seek, NULL); - res = sexp_make_input_port(in); + res = sexp_make_input_port(in, NULL); sexp_port_cookie(res) = cookie; return res; } @@ -495,7 +515,7 @@ sexp sexp_make_output_string_port () { cookie = sexp_vector(3, sexp_make_string(size, SEXP_VOID), size, sexp_make_integer(0)); out = funopen(cookie, NULL, &sstream_write, &sstream_seek, NULL); - res = sexp_make_output_port(out); + res = sexp_make_output_port(out, NULL); sexp_port_cookie(res) = cookie; return res; } @@ -512,14 +532,14 @@ sexp sexp_get_output_string (sexp port) { 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); + return sexp_make_input_port(in, NULL); } sexp sexp_make_output_string_port () { FILE *out; sexp buf = sexp_alloc_type(string, SEXP_STRING), res; out = open_memstream(&sexp_string_data(buf), &sexp_string_length(buf)); - res = sexp_make_input_port(out); + res = sexp_make_input_port(out, NULL); sexp_port_cookie(res) = buf; return res; } @@ -536,18 +556,18 @@ sexp sexp_get_output_string (sexp port) { #endif -sexp sexp_make_input_port (FILE* in) { +sexp sexp_make_input_port (FILE* in, char *path) { sexp p = sexp_alloc_type(port, SEXP_IPORT); sexp_port_stream(p) = in; - sexp_port_name(p) = NULL; + sexp_port_name(p) = path; sexp_port_line(p) = 0; return p; } -sexp sexp_make_output_port (FILE* out) { +sexp sexp_make_output_port (FILE* out, char *path) { sexp p = sexp_alloc_type(port, SEXP_OPORT); sexp_port_stream(p) = out; - sexp_port_name(p) = NULL; + sexp_port_name(p) = path; sexp_port_line(p) = 0; return p; } @@ -786,39 +806,58 @@ char* sexp_read_symbol(sexp in, int init) { return res; } -sexp sexp_read_float_tail(sexp in, long whole) { - double res = 0.0, scale=0.1; +sexp sexp_read_float_tail(sexp in, sexp_sint_t whole) { + sexp exponent; + double res=0.0, scale=0.1, e=0.0; 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); + if (c=='e' || c=='E') { + exponent = sexp_read_number(in, 10); + if (sexp_exceptionp(exponent)) return exponent; + e = (sexp_integerp(exponent) ? sexp_unbox_integer(exponent) + : sexp_flonump(exponent) ? sexp_flonum_value(exponent) : 0.0); + } else if ((c!=EOF) && ! is_separator(c)) + return sexp_read_error("invalid numeric syntax", + sexp_list1(sexp_make_character(c)), in); + return sexp_make_flonum((whole + res) * pow(10, e)); } sexp sexp_read_number(sexp in, int base) { - sexp tmp; - long res = 0, negativep = 0, c; + sexp f; + sexp_sint_t res = 0, negativep = 0, c; c = sexp_read_char(in); - if (c == '-') { + if (c == '-') negativep = 1; - } else if (isdigit(c)) { - res = c - '0'; - } + else if (isdigit(c)) + res = digit_value(c); - for (c=sexp_read_char(in); isxdigit(c); c=sexp_read_char(in)) - res = res * base + digit_value(c); - if (c=='.') { - if (base != 10) { + if (base == 16) + for (c=sexp_read_char(in); isxdigit(c); c=sexp_read_char(in)) + res = res * base + digit_value(c); + for (c=sexp_read_char(in); isdigit(c); c=sexp_read_char(in)) + res = res * base + digit_value(c); + + if (c=='.' || c=='e' || c=='E') { + if (base != 10) return sexp_read_error("decimal found in non-base 10", SEXP_NULL, in); + if (c!='.') + sexp_push_char(c, in); + f = sexp_read_float_tail(in, res); + if (! sexp_flonump(f)) return f; + if ((c!='.') && (sexp_flonum_value(f) == round(sexp_flonum_value(f)))) { + res = (sexp_sint_t) sexp_flonum_value(f); + } else { + if (negativep) sexp_flonum_value(f) = -sexp_flonum_value(f); + return f; } - 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); + if ((c!=EOF) && ! is_separator(c)) + return sexp_read_error("invalid numeric syntax", + sexp_list1(sexp_make_character(c)), in); } return sexp_make_integer(negativep ? -res : res); @@ -1009,7 +1048,14 @@ sexp sexp_read_raw (sexp in) { 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); + if (c1 == '-') { +#ifdef USE_FLONUMS + if (sexp_flonump(res)) + sexp_flonum_value(res) = -1 * sexp_flonum_value(res); + else +#endif + res = sexp_fx_mul(res, -1); + } } else { sexp_push_char(c2, in); str = sexp_read_symbol(in, c1); diff --git a/sexp.h b/sexp.h index 9784795f..c7cdff30 100644 --- a/sexp.h +++ b/sexp.h @@ -391,6 +391,7 @@ struct sexp_struct { #define sexp_write_char(c, p) (putc(c, sexp_port_stream(p))) #define sexp_write_string(s, p) (fputs(s, sexp_port_stream(p))) #define sexp_printf(p, ...) (fprintf(sexp_port_stream(p), __VA_ARGS__)) +#define sexp_scanf(p, ...) (fscanf(sexp_port_stream(p), __VA_ARGS__)) #define sexp_flush(p) (fflush(sexp_port_stream(p))) sexp sexp_alloc_tagged(size_t size, sexp_uint_t tag); @@ -420,12 +421,13 @@ sexp sexp_read_number(sexp in, int base); sexp sexp_read_raw(sexp in); sexp sexp_read(sexp in); sexp sexp_read_from_string(char *str); -sexp sexp_make_input_port(FILE* in); -sexp sexp_make_output_port(FILE* out); +sexp sexp_make_input_port(FILE* in, char *path); +sexp sexp_make_output_port(FILE* out, char *path); sexp sexp_make_input_string_port(sexp str); sexp sexp_make_output_string_port(); sexp sexp_get_output_string(sexp port); sexp sexp_make_exception(sexp kind, sexp message, sexp irritants, sexp file, sexp line); +sexp sexp_user_exception (char *message, sexp obj); sexp sexp_type_exception (char *message, sexp obj); sexp sexp_range_exception (sexp obj, sexp start, sexp end); sexp sexp_print_exception(sexp exn, sexp out); diff --git a/tests/test00-fact-3.res b/tests/basic/test00-fact-3.res similarity index 100% rename from tests/test00-fact-3.res rename to tests/basic/test00-fact-3.res diff --git a/tests/test00-fact-3.scm b/tests/basic/test00-fact-3.scm similarity index 100% rename from tests/test00-fact-3.scm rename to tests/basic/test00-fact-3.scm diff --git a/tests/test01-apply.res b/tests/basic/test01-apply.res similarity index 100% rename from tests/test01-apply.res rename to tests/basic/test01-apply.res diff --git a/tests/test01-apply.scm b/tests/basic/test01-apply.scm similarity index 100% rename from tests/test01-apply.scm rename to tests/basic/test01-apply.scm diff --git a/tests/test02-closure.res b/tests/basic/test02-closure.res similarity index 100% rename from tests/test02-closure.res rename to tests/basic/test02-closure.res diff --git a/tests/test02-closure.scm b/tests/basic/test02-closure.scm similarity index 100% rename from tests/test02-closure.scm rename to tests/basic/test02-closure.scm diff --git a/tests/test03-nested-closure.res b/tests/basic/test03-nested-closure.res similarity index 100% rename from tests/test03-nested-closure.res rename to tests/basic/test03-nested-closure.res diff --git a/tests/test03-nested-closure.scm b/tests/basic/test03-nested-closure.scm similarity index 100% rename from tests/test03-nested-closure.scm rename to tests/basic/test03-nested-closure.scm diff --git a/tests/test04-nested-let.res b/tests/basic/test04-nested-let.res similarity index 100% rename from tests/test04-nested-let.res rename to tests/basic/test04-nested-let.res diff --git a/tests/test04-nested-let.scm b/tests/basic/test04-nested-let.scm similarity index 100% rename from tests/test04-nested-let.scm rename to tests/basic/test04-nested-let.scm diff --git a/tests/test05-internal-define.res b/tests/basic/test05-internal-define.res similarity index 100% rename from tests/test05-internal-define.res rename to tests/basic/test05-internal-define.res diff --git a/tests/test05-internal-define.scm b/tests/basic/test05-internal-define.scm similarity index 100% rename from tests/test05-internal-define.scm rename to tests/basic/test05-internal-define.scm diff --git a/tests/test06-letrec.res b/tests/basic/test06-letrec.res similarity index 100% rename from tests/test06-letrec.res rename to tests/basic/test06-letrec.res diff --git a/tests/test06-letrec.scm b/tests/basic/test06-letrec.scm similarity index 100% rename from tests/test06-letrec.scm rename to tests/basic/test06-letrec.scm diff --git a/tests/test07-mutation.res b/tests/basic/test07-mutation.res similarity index 100% rename from tests/test07-mutation.res rename to tests/basic/test07-mutation.res diff --git a/tests/test07-mutation.scm b/tests/basic/test07-mutation.scm similarity index 100% rename from tests/test07-mutation.scm rename to tests/basic/test07-mutation.scm diff --git a/tests/test08-callcc.res b/tests/basic/test08-callcc.res similarity index 100% rename from tests/test08-callcc.res rename to tests/basic/test08-callcc.res diff --git a/tests/test08-callcc.scm b/tests/basic/test08-callcc.scm similarity index 100% rename from tests/test08-callcc.scm rename to tests/basic/test08-callcc.scm diff --git a/tests/test09-hygiene.res b/tests/basic/test09-hygiene.res similarity index 100% rename from tests/test09-hygiene.res rename to tests/basic/test09-hygiene.res diff --git a/tests/test09-hygiene.scm b/tests/basic/test09-hygiene.scm similarity index 100% rename from tests/test09-hygiene.scm rename to tests/basic/test09-hygiene.scm diff --git a/tests/r5rs-tests.scm b/tests/r5rs-tests.scm new file mode 100644 index 00000000..96d0dd09 --- /dev/null +++ b/tests/r5rs-tests.scm @@ -0,0 +1,372 @@ + +(define *tests-passed* 0) +(define *tests-failed* 0) + +(define-syntax test + (syntax-rules () + ((test expect expr) + (let ((str (call-with-output-string (lambda (out) (display 'expr out)))) + (res expr)) + (display str) + (write-char #\space) + (display (make-string (max 0 (- 72 (string-length str))) #\.)) + (flush-output) + (cond + ((equal? res expect) + (set! *tests-passed* (+ *tests-passed* 1)) + (display " [PASS]\n")) + (else + (set! *tests-failed* (+ *tests-failed* 1)) + (display " [FAIL]\n") + (display " expected ") (write expect) + (display " but got ") (write res) (newline))))))) + +(define (test-report) + (write *tests-passed*) + (display " out of ") + (write (+ *tests-passed* *tests-failed*)) + (display " passed (") + (write (* (/ *tests-passed* (+ *tests-passed* *tests-failed*)) 100)) + (display "%)") + (newline)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(test 8 ((lambda (x) (+ x x)) 4)) + +(test '(3 4 5 6) ((lambda x x) 3 4 5 6)) + +(test '(5 6) ((lambda (x y . z) z) 3 4 5 6)) + +(test 'yes (if (> 3 2) 'yes 'no)) + +(test 'no (if (> 2 3) 'yes 'no)) + +(test 1 (if (> 3 2) (- 3 2) (+ 3 2))) + +(test 'greater (cond ((> 3 2) 'greater) ((< 3 2) 'less))) + +(test 'equal (cond ((> 3 3) 'greater) ((< 3 3) 'less) (else 'equal))) + +(test 'composite (case (* 2 3) ((2 3 5 7) 'prime) ((1 4 6 8 9) 'composite))) + +(test 'consonant + (case (car '(c d)) + ((a e i o u) 'vowel) + ((w y) 'semivowel) + (else 'consonant))) + +(test #t (and (= 2 2) (> 2 1))) + +(test #f (and (= 2 2) (< 2 1))) + +(test '(f g) (and 1 2 'c '(f g))) + +(test #t (and)) + +(test #t (or (= 2 2) (> 2 1))) + +(test #t (or (= 2 2) (< 2 1))) + +(test '(b c) (or (memq 'b '(a b c)) (/ 3 0))) + +(test 6 (let ((x 2) (y 3)) (* x y))) + +(test 35 (let ((x 2) (y 3)) (let ((x 7) (z (+ x y))) (* z x)))) + +(test 70 (let ((x 2) (y 3)) (let* ((x 7) (z (+ x y))) (* z x)))) + +(test '#(0 1 2 3 4) + (do ((vec (make-vector 5)) + (i 0 (+ i 1))) + ((= i 5) vec) + (vector-set! vec i i))) + +(test 25 + (let ((x '(1 3 5 7 9))) + (do ((x x (cdr x)) + (sum 0 (+ sum (car x)))) + ((null? x) + sum)))) + +(test '((6 1 3) (-5 -2)) + (let loop ((numbers '(3 -2 1 6 -5)) (nonneg '()) (neg '())) + (cond + ((null? numbers) + (list nonneg neg)) + ((>= (car numbers) 0) + (loop (cdr numbers) (cons (car numbers) nonneg) neg)) + ((< (car numbers) 0) + (loop (cdr numbers) nonneg (cons (car numbers) neg)))))) + +(test '(list 3 4) `(list ,(+ 1 2) 4)) + +(test '(list a 'a) (let ((name 'a)) `(list ,name ',name))) + +(test '(a 3 4 5 6 b) + `(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b)) + +(test '(10 5 2 4 3 8) + `(10 5 ,(sqrt 4) ,@(map sqrt '(16 9)) 8)) + +(test '(a `(b ,(+ 1 2) ,(foo 4 d) e) f) + `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f)) + +(test '(a `(b ,x ,'y d) e) + (let ((name1 'x) + (name2 'y)) + `(a `(b ,,name1 ,',name2 d) e))) + +(test '(list 3 4) + (quasiquote (list (unquote (+ 1 2)) 4))) + +(test #t (eqv? 'a 'a)) + +(test #f (eqv? 'a 'b)) + +(test #t (eqv? '() '())) + +(test #f (eqv? (cons 1 2) (cons 1 2))) + +(test #f (eqv? (lambda () 1) (lambda () 2))) + +(test #t (let ((p (lambda (x) x))) (eqv? p p))) + +(test #t (eq? 'a 'a)) + +(test #f (eq? (list 'a) (list 'a))) + +(test #t (eq? '() '())) + +(test #t (eq? car car)) + +(test #t (let ((x '(a))) (eq? x x))) + +(test #t (let ((p (lambda (x) x))) (eq? p p))) + +(test #t (equal? 'a 'a)) + +(test #t (equal? '(a) '(a))) + +(test #t (equal? '(a (b) c) '(a (b) c))) + +(test #t (equal? "abc" "abc")) + +(test #t (equal? 2 2)) + +(test #t (equal? (make-vector 5 'a) (make-vector 5 'a))) + +(test 4 (max 3 4)) + +(test 4 (max 3.9 4)) + +(test 7 (+ 3 4)) + +(test 3 (+ 3)) + +(test 0 (+)) + +(test 4 (* 4)) + +(test 1 (*)) + +(test -1 (- 3 4)) + +(test -6 (- 3 4 5)) + +(test -3 (- 3)) + +(test 7 (abs -7)) + +(test 1 (modulo 13 4)) + +(test 1 (remainder 13 4)) + +(test 3 (modulo -13 4)) + +(test -1 (remainder -13 4)) + +(test -3 (modulo 13 -4)) + +(test 1 (remainder 13 -4)) + +(test -1 (modulo -13 -4)) + +(test -1 (remainder -13 -4)) + +(test 4 (gcd 32 -36)) + +(test 288 (lcm 32 -36)) + +(test -5 (floor -4.3)) + +(test -4 (ceiling -4.3)) + +(test -4 (truncate -4.3)) + +(test -4 (round -4.3)) + +(test 3 (floor 3.5)) + +(test 4 (ceiling 3.5)) + +(test 3 (truncate 3.5)) + +(test 4 (round 3.5)) + +(test 100 (string->number "100")) + +(test 256 (string->number "100" 16)) + +(test 100 (string->number "1e2")) + +(test #f (not 3)) + +(test #f (not (list 3))) + +(test #f (not '())) + +(test #f (not (list))) + +(test #f (not '())) + +(test #f (boolean? 0)) + +(test #f (boolean? '())) + +(test #t (pair? '(a . b))) + +(test #t (pair? '(a b c))) + +(test '(a) (cons 'a '())) + +(test '((a) b c d) (cons '(a) '(b c d))) + +(test '("a" b c) (cons "a" '(b c))) + +(test '(a . 3) (cons 'a 3)) + +(test '((a b) . c) (cons '(a b) 'c)) + +(test 'a (car '(a b c))) + +(test '(a) (car '((a) b c d))) + +(test 1 (car '(1 . 2))) + +(test '(b c d) (cdr '((a) b c d))) + +(test 2 (cdr '(1 . 2))) + +(test #t (list? '(a b c))) + +(test #t (list? '())) + +(test #f (list? '(a . b))) + +(test #f + (let ((x (list 'a))) + (set-cdr! x x) + (list? x))) + +(test '(a 7 c) (list 'a (+ 3 4) 'c)) + +(test '() (list)) + +(test 3 (length '(a b c))) + +(test 3 (length '(a (b) (c d e)))) + +(test 0 (length '())) + +(test '(x y) (append '(x) '(y))) + +(test '(a b c d) (append '(a) '(b c d))) + +(test '(a (b) (c)) (append '(a (b)) '((c)))) + +(test '(a b c . d) (append '(a b) '(c . d))) + +(test 'a (append '() 'a)) + +(test '(c b a) (reverse '(a b c))) + +(test '((e (f)) d (b c) a) (reverse '(a (b c) d (e (f))))) + +(test 'c (list-ref '(a b c d) 2)) + +(test '(a b c) (memq 'a '(a b c))) + +(test '(b c) (memq 'b '(a b c))) + +(test #f (memq 'a '(b c d))) + +(test #f (memq (list 'a) '(b (a) c))) + +(test '((a) c) (member (list 'a) '(b (a) c))) + +(test '(101 102) (memv 101 '(100 101 102))) + +(test #f (assq (list 'a) '(((a)) ((b)) ((c))))) + +(test '((a)) (assoc (list 'a) '(((a)) ((b)) ((c))))) + +(test '(5 7) (assv 5 '((2 3) (5 7) (11 13)))) + +(test #t (symbol? 'foo)) + +(test #t (symbol? (car '(a b)))) + +(test #f (symbol? "bar")) + +(test #t (symbol? 'nil)) + +(test #f (symbol? '())) + +(test "flying-fish" (symbol->string 'flying-fish)) + +(test "Martin" (symbol->string 'Martin)) + +(test "Malvina" (symbol->string (string->symbol "Malvina"))) + +(test '#(0 ("Sue" "Sue") "Anna") + (let ((vec (vector 0 '(2 2 2 2) "Anna"))) + (vector-set! vec 1 '("Sue" "Sue")) + vec)) + +(test '(dah dah didah) (vector->list '#(dah dah didah))) + +(test '#(dididit dah) (list->vector '(dididit dah))) + +(test #t (procedure? car)) + +(test #f (procedure? 'car)) + +(test #t (procedure? (lambda (x) (* x x)))) + +(test #f (procedure? '(lambda (x) (* x x)))) + +(test #t (call-with-current-continuation procedure?)) + +(test 7 (apply + (list 3 4))) + +(test '(b e h) (map cadr '((a b) (d e) (g h)))) + +(test '(1 4 27 256 3125) (map (lambda (n) (expt n n)) '(1 2 3 4 5))) + +(test '(5 7 9) (map + '(1 2 3) '(4 5 6))) + +(test '#(0 1 4 9 16) + (let ((v (make-vector 5))) + (for-each + (lambda (i) (vector-set! v i (* i i))) + '(0 1 2 3 4)) + v)) + +(test 3 (force (delay (+ 1 2)))) + +(test '(3 3) (let ((p (delay (+ 1 2)))) (list (force p) (force p)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(test-report) From 820c13e752af117475b34464eeffdb6b15f4ce4a Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Wed, 8 Apr 2009 11:55:38 +0900 Subject: [PATCH 096/154] reporting calling procedure name for exceptions --- eval.c | 70 ++++++++++++++++++++++++-------------------- sexp.c | 22 ++++++++++---- sexp.h | 12 ++++---- tests/r5rs-tests.scm | 37 +++++++++++------------ 4 files changed, 81 insertions(+), 60 deletions(-) diff --git a/eval.c b/eval.c index f41a1a13..413d39b4 100644 --- a/eval.c +++ b/eval.c @@ -109,6 +109,7 @@ static void shrink_bcode(sexp context, sexp_uint_t i) { sexp tmp; if (sexp_bytecode_length(sexp_context_bc(context)) != i) { tmp = sexp_alloc_tagged(sexp_sizeof(bytecode) + i, SEXP_BYTECODE); + sexp_bytecode_name(tmp) = SEXP_FALSE; sexp_bytecode_length(tmp) = i; sexp_bytecode_literals(tmp) = sexp_bytecode_literals(sexp_context_bc(context)); @@ -126,6 +127,7 @@ static void expand_bcode(sexp context, sexp_uint_t size) { tmp = sexp_alloc_tagged(sexp_sizeof(bytecode) + sexp_bytecode_length(sexp_context_bc(context))*2, SEXP_BYTECODE); + sexp_bytecode_name(tmp) = SEXP_FALSE; sexp_bytecode_length(tmp) = sexp_bytecode_length(sexp_context_bc(context))*2; sexp_bytecode_literals(tmp) @@ -189,6 +191,7 @@ static sexp sexp_make_synclo (sexp env, sexp fv, sexp expr) { static sexp sexp_make_lambda(sexp params) { sexp res = sexp_alloc_type(lambda, SEXP_LAMBDA); + sexp_lambda_name(res) = SEXP_FALSE; sexp_lambda_params(res) = params; sexp_lambda_fv(res) = SEXP_NULL; sexp_lambda_sv(res) = SEXP_NULL; @@ -233,6 +236,7 @@ static sexp sexp_make_context(sexp *stack, sexp env) { env = sexp_make_standard_env(sexp_make_integer(5)); sexp_context_bc(res) = sexp_alloc_tagged(sexp_sizeof(bytecode)+INIT_BCODE_SIZE, SEXP_BYTECODE); + sexp_bytecode_name(sexp_context_bc(res)) = SEXP_FALSE; sexp_bytecode_length(sexp_context_bc(res)) = INIT_BCODE_SIZE; sexp_bytecode_literals(sexp_context_bc(res)) = SEXP_NULL; sexp_context_lambda(res) = SEXP_FALSE; @@ -286,7 +290,7 @@ static sexp sexp_identifier_eq (sexp e1, sexp id1, sexp e2, sexp id2) { static sexp sexp_compile_error(char *message, sexp irritants) { return sexp_make_exception(the_compile_error_symbol, sexp_c_string(message), - irritants, SEXP_FALSE, SEXP_FALSE); + irritants, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE); } #define analyze_check_exception(x) do {if (sexp_exceptionp(x)) \ @@ -557,10 +561,6 @@ static void sexp_context_patch_label (sexp context, sexp_sint_t label) { static sexp finalize_bytecode (sexp context) { emit(OP_RET, context); shrink_bcode(context, sexp_context_pos(context)); -/* sexp_disasm(sexp_context_bc(context), */ -/* env_global_ref(sexp_context_env(context), */ -/* the_cur_err_symbol, */ -/* SEXP_FALSE)); */ return sexp_context_bc(context); } @@ -643,6 +643,8 @@ static void generate_set (sexp set, sexp context) { sexp ref = sexp_set_var(set), lambda; /* compile the value */ sexp_context_tailp(context) = 0; + if (sexp_lambdap(sexp_set_value(set))) + sexp_lambda_name(sexp_set_value(set)) = sexp_ref_name(ref); generate(sexp_set_value(set), context); if (! sexp_lambdap(sexp_ref_loc(ref))) { /* global vars are set directly */ @@ -800,6 +802,7 @@ static void generate_lambda (sexp lambda, sexp context) { ? 1 : 0); len = sexp_length(sexp_lambda_params(lambda)); bc = finalize_bytecode(ctx); + sexp_bytecode_name(bc) = sexp_lambda_name(lambda); if (sexp_nullp(fv)) { /* shortcut, no free vars */ vec = sexp_make_vector(sexp_make_integer(0), SEXP_VOID); @@ -943,6 +946,7 @@ static sexp make_opcode_procedure (sexp op, sexp_uint_t i, sexp env, sexp_push(refs, sexp_make_ref(sexp_car(ls), env_cell(env, sexp_car(ls)))); generate_opcode_app(sexp_cons(op, sexp_reverse(refs)), context); bc = finalize_bytecode(context); + sexp_bytecode_name(bc) = sexp_c_string(sexp_opcode_name(op)); res = sexp_make_procedure(sexp_make_integer(0), sexp_make_integer(i), bc, @@ -982,16 +986,17 @@ static sexp_uint_t sexp_restore_stack(sexp saved, sexp *current) { #define _UWORD0 ((sexp_uint_t*)ip)[0] #define _SWORD0 ((sexp_sint_t*)ip)[0] -#define sexp_raise(msg, args) do {stack[top]=sexp_compile_error(msg, args); \ - top++; \ - goto call_error_handler;} \ +#define sexp_raise(msg, args) do {stack[top]=sexp_user_exception(self, msg, args); \ + top++; \ + goto call_error_handler;} \ while (0) #define sexp_check_exception() do {if (sexp_exceptionp(_ARG1)) \ goto call_error_handler;} \ while (0) -sexp vm(sexp bc, sexp cp, sexp context, sexp* stack, sexp_sint_t top) { +sexp vm (sexp self, sexp context, sexp* stack, sexp_sint_t top) { + sexp bc = sexp_procedure_code(self), cp = sexp_procedure_vars(self); unsigned char *ip=sexp_bytecode_data(bc); sexp tmp1, tmp2, env=sexp_context_env(context); sexp_sint_t i, j, k, fp=top-4; @@ -1006,38 +1011,39 @@ sexp vm(sexp bc, sexp cp, sexp context, sexp* stack, sexp_sint_t top) { #endif switch (*ip++) { case OP_NOOP: - fprintf(stderr, "<<>>\n"); break; case OP_ERROR: call_error_handler: tmp1 = env_global_ref(env, the_cur_err_symbol, SEXP_FALSE); sexp_print_exception(_ARG1, tmp1); - tmp1 = env_global_ref(env, the_err_handler_symbol, SEXP_FALSE); + self = env_global_ref(env, the_err_handler_symbol, SEXP_FALSE); stack[top] = (sexp) 1; stack[top+1] = sexp_make_integer(ip+4); - stack[top+2] = cp; + stack[top+2] = self; top += 3; - bc = sexp_procedure_code(tmp1); + bc = sexp_procedure_code(self); ip = sexp_bytecode_data(bc); - cp = sexp_procedure_vars(tmp1); + cp = sexp_procedure_vars(self); break; case OP_RESUMECC: tmp1 = stack[fp-1]; top = sexp_restore_stack(sexp_vector_ref(cp, 0), stack); fp = sexp_unbox_integer(_ARG1); - cp = _ARG2; + self = _ARG2; + bc = sexp_procedure_code(self); + cp = sexp_procedure_vars(self); ip = (unsigned char*) sexp_unbox_integer(_ARG3); i = sexp_unbox_integer(_ARG4); top -= 4; _ARG1 = tmp1; break; case OP_CALLCC: - tmp1 = _ARG1; - i = 1; stack[top] = sexp_make_integer(1); stack[top+1] = sexp_make_integer(ip); - stack[top+2] = cp; + stack[top+2] = self; stack[top+3] = sexp_make_integer(fp); + tmp1 = _ARG1; + i = 1; tmp2 = sexp_vector(1, sexp_save_stack(stack, top+4)); _ARG1 = sexp_make_procedure(sexp_make_integer(0), sexp_make_integer(1), @@ -1046,7 +1052,6 @@ sexp vm(sexp bc, sexp cp, sexp context, sexp* stack, sexp_sint_t top) { top++; ip -= sizeof(sexp); goto make_call; - break; case OP_APPLY1: tmp1 = _ARG1; tmp2 = _ARG2; @@ -1064,7 +1069,9 @@ sexp vm(sexp bc, sexp cp, sexp context, sexp* stack, sexp_sint_t top) { tmp2 = stack[fp+3]; j = sexp_unbox_integer(stack[fp]); ip = ((unsigned char*) sexp_unbox_integer(stack[fp+1])) - sizeof(sexp); - cp = stack[fp+2]; + self = stack[fp+2]; + cp = sexp_procedure_vars(self); + bc = sexp_procedure_vars(self); /* copy new args into place */ for (k=0; k sexp_make_integer(0))) { sexp_write_string(" on line ", out); @@ -173,6 +182,7 @@ static sexp sexp_read_error (char *message, sexp irritants, sexp port) { return sexp_make_exception(the_read_error_symbol, sexp_c_string(message), irritants, + SEXP_FALSE, name, sexp_make_integer(sexp_port_line(port))); } diff --git a/sexp.h b/sexp.h index c7cdff30..a17c5433 100644 --- a/sexp.h +++ b/sexp.h @@ -105,7 +105,7 @@ struct sexp_struct { sexp cookie; } port; struct { - sexp kind, message, irritants, file, line; + sexp kind, message, irritants, procedure, file, line; } exception; /* runtime types */ struct { @@ -114,7 +114,7 @@ struct sexp_struct { } env; struct { sexp_uint_t length; - sexp literals; + sexp name, literals; unsigned char data[]; } bytecode; struct { @@ -269,12 +269,14 @@ struct sexp_struct { #define sexp_exception_kind(p) ((p)->value.exception.kind) #define sexp_exception_message(p) ((p)->value.exception.message) #define sexp_exception_irritants(p) ((p)->value.exception.irritants) +#define sexp_exception_procedure(p) ((p)->value.exception.procedure) #define sexp_exception_file(p) ((p)->value.exception.file) #define sexp_exception_line(p) ((p)->value.exception.line) #define sexp_bytecode_length(x) ((x)->value.bytecode.length) -#define sexp_bytecode_data(x) ((x)->value.bytecode.data) +#define sexp_bytecode_name(x) ((x)->value.bytecode.name) #define sexp_bytecode_literals(x) ((x)->value.bytecode.literals) +#define sexp_bytecode_data(x) ((x)->value.bytecode.data) #define sexp_env_flags(x) ((x)->value.env.flags) #define sexp_env_parent(x) ((x)->value.env.parent) @@ -426,8 +428,8 @@ sexp sexp_make_output_port(FILE* out, char *path); sexp sexp_make_input_string_port(sexp str); sexp sexp_make_output_string_port(); sexp sexp_get_output_string(sexp port); -sexp sexp_make_exception(sexp kind, sexp message, sexp irritants, sexp file, sexp line); -sexp sexp_user_exception (char *message, sexp obj); +sexp sexp_make_exception(sexp kind, sexp message, sexp irritants, sexp procedure, sexp file, sexp line); +sexp sexp_user_exception (sexp self, char *message, sexp obj); sexp sexp_type_exception (char *message, sexp obj); sexp sexp_range_exception (sexp obj, sexp start, sexp end); sexp sexp_print_exception(sexp exn, sexp out); diff --git a/tests/r5rs-tests.scm b/tests/r5rs-tests.scm index 96d0dd09..e11ced4c 100644 --- a/tests/r5rs-tests.scm +++ b/tests/r5rs-tests.scm @@ -1,32 +1,33 @@ +(define *tests-run* 0) (define *tests-passed* 0) -(define *tests-failed* 0) (define-syntax test (syntax-rules () ((test expect expr) - (let ((str (call-with-output-string (lambda (out) (display 'expr out)))) - (res expr)) - (display str) - (write-char #\space) - (display (make-string (max 0 (- 72 (string-length str))) #\.)) - (flush-output) - (cond - ((equal? res expect) - (set! *tests-passed* (+ *tests-passed* 1)) - (display " [PASS]\n")) - (else - (set! *tests-failed* (+ *tests-failed* 1)) - (display " [FAIL]\n") - (display " expected ") (write expect) - (display " but got ") (write res) (newline))))))) + (begin + (set! *tests-run* (+ *tests-run* 1)) + (let ((str (call-with-output-string (lambda (out) (display 'expr out)))) + (res expr)) + (display str) + (write-char #\space) + (display (make-string (max 0 (- 72 (string-length str))) #\.)) + (flush-output) + (cond + ((equal? res expect) + (set! *tests-passed* (+ *tests-passed* 1)) + (display " [PASS]\n")) + (else + (display " [FAIL]\n") + (display " expected ") (write expect) + (display " but got ") (write res) (newline)))))))) (define (test-report) (write *tests-passed*) (display " out of ") - (write (+ *tests-passed* *tests-failed*)) + (write *tests-run*) (display " passed (") - (write (* (/ *tests-passed* (+ *tests-passed* *tests-failed*)) 100)) + (write (* (/ *tests-passed* *tests-run*) 100)) (display "%)") (newline)) From b36c0d2e3ade0daec1889af24b3302b993b675f7 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Wed, 8 Apr 2009 17:04:48 +0900 Subject: [PATCH 097/154] exceptions don't print by default --- eval.c | 40 ++++++++++++++++++++++++++-------------- main.c | 24 ++++++++++++++++++------ opcodes.c | 1 + sexp.c | 50 +++++++++++++++++++++++++++++++------------------- 4 files changed, 76 insertions(+), 39 deletions(-) diff --git a/eval.c b/eval.c index 413d39b4..196c5452 100644 --- a/eval.c +++ b/eval.c @@ -337,6 +337,8 @@ static sexp analyze_var_ref (sexp x, sexp context) { cell = env_cell_create(sexp_context_env(context), x, SEXP_UNDEF); } } + if (sexp_macrop(sexp_cdr(cell)) || sexp_corep(sexp_cdr(cell))) + return sexp_compile_error("invalid use of syntax as value", sexp_list1(x)); return sexp_make_ref(x, cell); } @@ -437,8 +439,10 @@ static sexp analyze_define_syntax (sexp x, sexp context) { return sexp_compile_error("non-top-level define-syntax", sexp_list1(x)); proc = eval_in_context(sexp_caddr(x), context); analyze_check_exception(proc); - cell = env_cell_create(sexp_context_env(context), name, SEXP_VOID); - sexp_cdr(cell) = sexp_make_macro(proc, sexp_context_env(context)); + if (sexp_procedurep(proc)) { + cell = env_cell_create(sexp_context_env(context), name, SEXP_VOID); + sexp_cdr(cell) = sexp_make_macro(proc, sexp_context_env(context)); + } return SEXP_VOID; } @@ -447,9 +451,10 @@ static sexp analyze_bind_syntax (sexp ls, sexp eval_ctx, sexp bind_ctx) { for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) { proc = eval_in_context(sexp_cadar(ls), eval_ctx); analyze_check_exception(proc); - sexp_push(sexp_env_bindings(sexp_context_env(bind_ctx)), - sexp_cons(sexp_caar(ls), - sexp_make_macro(proc, sexp_context_env(eval_ctx)))); + if (sexp_procedurep(proc)) + sexp_push(sexp_env_bindings(sexp_context_env(bind_ctx)), + sexp_cons(sexp_caar(ls), + sexp_make_macro(proc, sexp_context_env(eval_ctx)))); } return SEXP_VOID; } @@ -497,7 +502,7 @@ static sexp analyze (sexp x, sexp context) { case CORE_IF: res = analyze_if(x, context); break; case CORE_BEGIN: - res = analyze_seq(x, context); break; + res = analyze_seq(sexp_cdr(x), context); break; case CORE_QUOTE: res = sexp_make_lit(sexp_cadr(x)); break; case CORE_DEFINE_SYNTAX: @@ -1014,16 +1019,17 @@ sexp vm (sexp self, sexp context, sexp* stack, sexp_sint_t top) { break; case OP_ERROR: call_error_handler: - tmp1 = env_global_ref(env, the_cur_err_symbol, SEXP_FALSE); - sexp_print_exception(_ARG1, tmp1); - self = env_global_ref(env, the_err_handler_symbol, SEXP_FALSE); stack[top] = (sexp) 1; stack[top+1] = sexp_make_integer(ip+4); stack[top+2] = self; - top += 3; + stack[top+3] = sexp_make_integer(fp); + top += 4; + self = env_global_ref(env, the_err_handler_symbol, SEXP_FALSE); bc = sexp_procedure_code(self); ip = sexp_bytecode_data(bc); cp = sexp_procedure_vars(self); + fp = top-4; + /* sexp_print_stack(stack, top, fp, tmp1); */ break; case OP_RESUMECC: tmp1 = stack[fp-1]; @@ -1327,6 +1333,8 @@ sexp vm (sexp self, sexp context, sexp* stack, sexp_sint_t top) { top--; break; case OP_DIV: + if (_ARG2 == sexp_make_integer(0)) + sexp_raise("divide by zero", SEXP_NULL); if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) _ARG2 = sexp_fp_div(sexp_integer_to_flonum(_ARG1), sexp_integer_to_flonum(_ARG2)); @@ -1343,7 +1351,7 @@ sexp vm (sexp self, sexp context, sexp* stack, sexp_sint_t top) { break; case OP_QUOTIENT: if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) { - if (_ARG1 == sexp_make_integer(0)) + if (_ARG2 == sexp_make_integer(0)) sexp_raise("divide by zero", SEXP_NULL); _ARG2 = sexp_fx_div(_ARG1, _ARG2); top--; @@ -1352,7 +1360,7 @@ sexp vm (sexp self, sexp context, sexp* stack, sexp_sint_t top) { break; case OP_REMAINDER: if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) { - if (_ARG1 == sexp_make_integer(0)) + if (_ARG2 == sexp_make_integer(0)) sexp_raise("divide by zero", SEXP_NULL); tmp1 = sexp_fx_rem(_ARG1, _ARG2); top--; @@ -1559,9 +1567,14 @@ static void sexp_warn_undefs (sexp from, sexp to, sexp out) { sexp sexp_load (sexp source, sexp env) { sexp x, res, in, tmp, out, context = sexp_make_context(NULL, env); + out = env_global_ref(env, the_cur_err_symbol, SEXP_FALSE); tmp = sexp_env_bindings(env); sexp_context_tailp(context) = 0; in = sexp_open_input_file(source); + if (sexp_exceptionp(in)) { + sexp_print_exception(in, out); + return in; + } while ((x=sexp_read(in)) != (sexp) SEXP_EOF) { res = eval_in_context(x, context); if (sexp_exceptionp(res)) @@ -1571,7 +1584,6 @@ sexp sexp_load (sexp source, sexp env) { res = SEXP_VOID; sexp_close_port(in); #ifdef USE_WARN_UNDEFS - out = env_global_ref(env, the_cur_err_symbol, SEXP_FALSE); if (sexp_oportp(out)) sexp_warn_undefs(sexp_env_bindings(env), tmp, out); #endif @@ -1770,7 +1782,7 @@ sexp eval_in_context (sexp obj, sexp context) { sexp_print_exception(thunk, env_global_ref(sexp_context_env(context), the_cur_err_symbol, SEXP_FALSE)); - return SEXP_VOID; + return thunk; } return apply(thunk, SEXP_NULL, context); } diff --git a/main.c b/main.c index f666c07a..62da5068 100644 --- a/main.c +++ b/main.c @@ -31,13 +31,24 @@ void repl (sexp context) { } void run_main (int argc, char **argv) { - sexp env, obj, out=NULL, res, context, err_handler; + sexp env, out=NULL, res, context, perr_cell, err_cell, err_handler; sexp_uint_t i, quit=0, init_loaded=0; env = sexp_make_standard_env(sexp_make_integer(5)); env_define(env, the_interaction_env_symbol, env); + out = env_global_ref(env, the_cur_out_symbol, SEXP_FALSE); + err_cell = env_cell(env, the_cur_err_symbol); + perr_cell = env_cell(env, sexp_intern("print-exception")); context = sexp_make_context(NULL, env); sexp_context_tailp(context) = 0; + if (err_cell && perr_cell && sexp_opcodep(sexp_cdr(perr_cell))) { + emit(OP_GLOBAL_KNOWN_REF, context); + emit_word((sexp_uint_t)err_cell, context); + emit(OP_LOCAL_REF, context); + emit_word(0, context); + emit(OP_FCALL2, context); + emit_word((sexp_uint_t)sexp_opcode_data(sexp_cdr(perr_cell)), context); + } emit_push(SEXP_VOID, context); emit(OP_DONE, context); err_handler = sexp_make_procedure(sexp_make_integer(0), @@ -54,11 +65,12 @@ void run_main (int argc, char **argv) { case 'p': if (! init_loaded++) sexp_load(sexp_c_string(sexp_init_file), env); - obj = sexp_read_from_string(argv[i+1]); - res = eval_in_context(obj, context); - if (argv[i][1] == 'p') { - if (! out) - out = env_global_ref(env, the_cur_out_symbol, SEXP_FALSE); + res = sexp_read_from_string(argv[i+1]); + if (! sexp_exceptionp(res)) + res = eval_in_context(res, context); + if (sexp_exceptionp(res)) { + sexp_print_exception(res, out); + } else if (argv[i][1] == 'p') { sexp_write(res, out); sexp_write_char('\n', out); } diff --git a/opcodes.c b/opcodes.c index 8305cf3f..aaa990ae 100644 --- a/opcodes.c +++ b/opcodes.c @@ -82,6 +82,7 @@ _FN1(SEXP_OPORT, "close-output-port", 0, sexp_close_port), _FN1(SEXP_FIXNUM, "null-environment", 0, sexp_make_null_env), _FN1(SEXP_FIXNUM, "scheme-report-environment", 0, sexp_make_standard_env), _FN2(SEXP_STRING, SEXP_ENV, "%load", 0, sexp_load), +_FN2(SEXP_EXCEPTION, SEXP_OPORT, "print-exception", 0, sexp_print_exception), _FN2OPT(SEXP_FIXNUM, SEXP_CHAR, "make-string", sexp_make_character(' '), sexp_make_string), _FN2(SEXP_STRING, SEXP_STRING, "string-cmp", 0, sexp_string_cmp), _FN2(SEXP_STRING, SEXP_STRING, "string-cmp-ci", 0, sexp_string_cmp_ci), diff --git a/sexp.c b/sexp.c index 38409f05..18b903f7 100644 --- a/sexp.c +++ b/sexp.c @@ -760,44 +760,48 @@ void sexp_write (sexp obj, sexp out) { char* sexp_read_string(sexp in) { char *buf, *tmp, *res; - int c, len, size=128; + int c, i=0, size=128; - buf = sexp_alloc(size); /* XXXX grow! */ - tmp = buf; + buf = sexp_alloc(size); for (c=sexp_read_char(in); c != '"'; c=sexp_read_char(in)) { if (c == EOF) { sexp_free(buf); return NULL; - } else if (c == '\\') { + } + if (c == '\\') { c=sexp_read_char(in); switch (c) { case 'n': c = '\n'; break; case 't': c = '\t'; break; } - *tmp++ = c; + buf[i++] = c; } else { - *tmp++ = c; + buf[i++] = c; + } + if (i >= size) { + tmp = sexp_alloc(2*size); + memcpy(tmp, buf, i); + sexp_free(buf); + buf = tmp; } } - *tmp++ = '\0'; - len = tmp - buf; - res = sexp_alloc(len); - memcpy(res, buf, len); + buf[i] = '\0'; + res = sexp_alloc(i); + memcpy(res, buf, i); sexp_free(buf); return res; } char* sexp_read_symbol(sexp in, int init) { char *buf, *tmp, *res; - int c, len, size=128; + int c, i=0, size=128; buf = sexp_alloc(size); - tmp = buf; if (init != EOF) - *tmp++ = init; + buf[i++] = init; while (1) { c=sexp_read_char(in); @@ -805,13 +809,18 @@ char* sexp_read_symbol(sexp in, int init) { sexp_push_char(c, in); break; } - *tmp++ = c; + buf[i++] = c; + if (i >= size) { + tmp = sexp_alloc(2*size); + memcpy(tmp, buf, i); + sexp_free(buf); + buf = tmp; + } } - *tmp++ = '\0'; - len = tmp - buf; - res = sexp_alloc(len); - memcpy(res, buf, len); + buf[i] = '\0'; + res = sexp_alloc(i); + memcpy(res, buf, i); sexp_free(buf); return res; } @@ -916,7 +925,10 @@ sexp sexp_read_raw (sexp in) { break; case '"': str = sexp_read_string(in); - res = sexp_c_string(str); + if (! str) + res = sexp_read_error("premature end of string", SEXP_NULL, in); + else + res = sexp_c_string(str); sexp_free(str); break; case '(': From 90280258d08b1534911ff4ab139033ba910e83c0 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Wed, 8 Apr 2009 18:02:47 +0900 Subject: [PATCH 098/154] fixing bug in return IP for exceptions --- eval.c | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/eval.c b/eval.c index 196c5452..3f359cab 100644 --- a/eval.c +++ b/eval.c @@ -1020,7 +1020,7 @@ sexp vm (sexp self, sexp context, sexp* stack, sexp_sint_t top) { case OP_ERROR: call_error_handler: stack[top] = (sexp) 1; - stack[top+1] = sexp_make_integer(ip+4); + stack[top+1] = sexp_make_integer(ip); stack[top+2] = self; stack[top+3] = sexp_make_integer(fp); top += 4; @@ -1029,7 +1029,6 @@ sexp vm (sexp self, sexp context, sexp* stack, sexp_sint_t top) { ip = sexp_bytecode_data(bc); cp = sexp_procedure_vars(self); fp = top-4; - /* sexp_print_stack(stack, top, fp, tmp1); */ break; case OP_RESUMECC: tmp1 = stack[fp-1]; From 60a435825d6cd11f15ef6499e45e693cb9609b37 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Wed, 8 Apr 2009 22:44:24 +0900 Subject: [PATCH 099/154] adding unhygiene tests --- tests/basic/test09-hygiene.res | 1 + tests/basic/test09-hygiene.scm | 13 +++++++++++++ tests/basic/test10-unhygiene.res | 4 ++++ tests/basic/test10-unhygiene.scm | 27 +++++++++++++++++++++++++++ 4 files changed, 45 insertions(+) create mode 100644 tests/basic/test10-unhygiene.res create mode 100644 tests/basic/test10-unhygiene.scm diff --git a/tests/basic/test09-hygiene.res b/tests/basic/test09-hygiene.res index 94ebaf90..8a1218a1 100644 --- a/tests/basic/test09-hygiene.res +++ b/tests/basic/test09-hygiene.res @@ -2,3 +2,4 @@ 2 3 4 +5 diff --git a/tests/basic/test09-hygiene.scm b/tests/basic/test09-hygiene.scm index f6c547a4..c3f0bb7e 100644 --- a/tests/basic/test09-hygiene.scm +++ b/tests/basic/test09-hygiene.scm @@ -10,3 +10,16 @@ (write (or #f tmp)) (newline)) +(write + (letrec-syntax + ((myor + (er-macro-transformer + (lambda (expr rename compare) + (if (null? (cdr expr)) + #f + (list (rename 'let) (list (list (rename 'tmp) (cadr expr))) + (list (rename 'if) (rename 'tmp) + (rename 'tmp) + (cons (rename 'myor) (cddr expr))))))))) + (let ((tmp 5)) (myor #f tmp)))) +(newline) diff --git a/tests/basic/test10-unhygiene.res b/tests/basic/test10-unhygiene.res new file mode 100644 index 00000000..69584714 --- /dev/null +++ b/tests/basic/test10-unhygiene.res @@ -0,0 +1,4 @@ +1 +1 +1 +6 diff --git a/tests/basic/test10-unhygiene.scm b/tests/basic/test10-unhygiene.scm new file mode 100644 index 00000000..90bc5ef6 --- /dev/null +++ b/tests/basic/test10-unhygiene.scm @@ -0,0 +1,27 @@ + +(define-syntax aif + (sc-macro-transformer + (lambda (form environment) + (let ((condition + (make-syntactic-closure environment '() (cadr form))) + (consequent + (make-syntactic-closure environment '(it) (caddr form))) + (alternative + (make-syntactic-closure environment '() (cadddr form)))) + `(let ((it ,condition)) + (if it + ,consequent + ,alternative)))))) + +(write (aif 1 it 3)) +(newline) + +(write (let ((it 4)) (aif 1 it 3))) +(newline) + +(write (let ((it 4)) (aif (let ((it 5)) 1) it 3))) +(newline) + +(write (let ((it 4)) (aif (let ((it 5)) 1) (let ((it 6)) it) 3))) +(newline) + From 8a5cfbddc0315e4b55086f3a349c397ca7743c55 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Wed, 8 Apr 2009 23:07:19 +0900 Subject: [PATCH 100/154] allowing unhygienic insertion --- eval.c | 15 +++++++++------ sexp.h | 3 ++- tests/basic/test10-unhygiene.res | 2 ++ tests/basic/test10-unhygiene.scm | 22 ++++++++++++++++++++++ 4 files changed, 35 insertions(+), 7 deletions(-) diff --git a/eval.c b/eval.c index 3f359cab..8d3faadb 100644 --- a/eval.c +++ b/eval.c @@ -242,6 +242,7 @@ static sexp sexp_make_context(sexp *stack, sexp env) { sexp_context_lambda(res) = SEXP_FALSE; sexp_context_stack(res) = stack; sexp_context_env(res) = env; + sexp_context_fv(res) = SEXP_NULL; sexp_context_depth(res) = 0; sexp_context_pos(res) = 0; sexp_context_top(res) = 0; @@ -256,6 +257,7 @@ static sexp sexp_child_context(sexp context, sexp lambda) { sexp_context_lambda(ctx) = lambda; sexp_context_env(ctx) = sexp_context_env(context); sexp_context_top(ctx) = sexp_context_top(context); + sexp_context_fv(ctx) = sexp_context_fv(context); sexp_context_tracep(ctx) = sexp_context_tracep(context); return ctx; } @@ -326,16 +328,15 @@ static sexp analyze_seq (sexp ls, sexp context) { } static sexp analyze_var_ref (sexp x, sexp context) { - sexp cell = env_cell(sexp_context_env(context), x); + sexp env = sexp_context_env(context), cell; + cell = env_cell(env, x); if (! cell) { if (sexp_synclop(x)) { - cell = env_cell_create(sexp_synclo_env(x), - sexp_synclo_expr(x), - SEXP_UNDEF); + if (sexp_memq(x, sexp_context_fv(context)) != SEXP_FALSE) + env = sexp_synclo_env(x); x = sexp_synclo_expr(x); - } else { - cell = env_cell_create(sexp_context_env(context), x, SEXP_UNDEF); } + cell = env_cell_create(env, x, SEXP_UNDEF); } if (sexp_macrop(sexp_cdr(cell)) || sexp_corep(sexp_cdr(cell))) return sexp_compile_error("invalid use of syntax as value", sexp_list1(x)); @@ -543,6 +544,8 @@ static sexp analyze (sexp x, sexp context) { } else if (sexp_synclop(x)) { context = sexp_child_context(context, sexp_context_lambda(context)); sexp_context_env(context) = sexp_synclo_env(x); + sexp_context_fv(context) = sexp_append(sexp_synclo_free_vars(x), + sexp_context_fv(context)); x = sexp_synclo_expr(x); goto loop; } else { diff --git a/sexp.h b/sexp.h index a17c5433..9f8d4fe4 100644 --- a/sexp.h +++ b/sexp.h @@ -159,7 +159,7 @@ struct sexp_struct { } lit; /* compiler state */ struct { - sexp bc, lambda, *stack, env; + sexp bc, lambda, *stack, env, fv; sexp_uint_t pos, top, depth, tailp, tracep; } context; } value; @@ -338,6 +338,7 @@ struct sexp_struct { #define sexp_context_stack(x) ((x)->value.context.stack) #define sexp_context_depth(x) ((x)->value.context.depth) #define sexp_context_bc(x) ((x)->value.context.bc) +#define sexp_context_fv(x) ((x)->value.context.fv) #define sexp_context_pos(x) ((x)->value.context.pos) #define sexp_context_top(x) ((x)->value.context.top) #define sexp_context_lambda(x) ((x)->value.context.lambda) diff --git a/tests/basic/test10-unhygiene.res b/tests/basic/test10-unhygiene.res index 69584714..0d174dc4 100644 --- a/tests/basic/test10-unhygiene.res +++ b/tests/basic/test10-unhygiene.res @@ -2,3 +2,5 @@ 1 1 6 +7 +8 diff --git a/tests/basic/test10-unhygiene.scm b/tests/basic/test10-unhygiene.scm index 90bc5ef6..c60a6bca 100644 --- a/tests/basic/test10-unhygiene.scm +++ b/tests/basic/test10-unhygiene.scm @@ -25,3 +25,25 @@ (write (let ((it 4)) (aif (let ((it 5)) 1) (let ((it 6)) it) 3))) (newline) +(write + (letrec-syntax + ((myor + (er-macro-transformer + (lambda (expr rename compare) + (if (null? (cdr expr)) + #f + (list (rename 'let) (list (list (rename 'it) (cadr expr))) + (list (rename 'if) (rename 'it) + (rename 'it) + (cons (rename 'myor) (cddr expr))))))))) + (let ((it 7)) (myor #f it)))) +(newline) + +(define-syntax define-foo + (sc-macro-transformer + (lambda (form environment) + (make-syntactic-closure environment '(foo) `(define foo 8))))) + +(define-foo) +(write foo) +(newline) From b4aaf9b3863ffb492d97682179f2bf1df4f6ee90 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Wed, 8 Apr 2009 10:19:16 -0400 Subject: [PATCH 101/154] fixes for linux --- defaults.h | 1 + sexp.c | 2 +- sexp.h | 6 +++--- 3 files changed, 5 insertions(+), 4 deletions(-) diff --git a/defaults.h b/defaults.h index f2399aff..949c117e 100644 --- a/defaults.h +++ b/defaults.h @@ -13,6 +13,7 @@ #define SEXP_BSD 1 #else #define SEXP_BSD 0 +#define _GNU_SOURCE #endif #ifndef USE_BOEHM diff --git a/sexp.c b/sexp.c index 18b903f7..4b8e0ce5 100644 --- a/sexp.c +++ b/sexp.c @@ -559,7 +559,7 @@ sexp sexp_get_output_string (sexp port) { fflush(sexp_port_stream(port)); return sexp_substring(cookie, sexp_make_integer(0), - sexp_string_length(cookie)); + sexp_make_integer(sexp_string_length(cookie))); } #endif diff --git a/sexp.h b/sexp.h index 9f8d4fe4..c2bccf53 100644 --- a/sexp.h +++ b/sexp.h @@ -5,6 +5,9 @@ #ifndef SEXP_H #define SEXP_H +#include "config.h" +#include "defaults.h" + #include #include #include @@ -13,9 +16,6 @@ #include #include -#include "config.h" -#include "defaults.h" - /* tagging system * bits end in 00: pointer * 01: fixnum From 609ca8df2e46c90f08b85bd47cac4f865fca6416 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 9 Apr 2009 00:46:21 +0900 Subject: [PATCH 102/154] preparing for preview release --- Makefile | 42 +++++++++++++++++++++--------------------- README | 26 ++++++++++++++++++++++++++ VERSION | 1 + debug.c | 5 +++-- defaults.h | 4 ++++ eval.c | 28 +++++++++++++++++++++++++--- eval.h | 5 +++-- init.scm | 10 ++++++++++ opcodes.c | 8 ++++++-- sexp.c | 8 ++++---- 10 files changed, 103 insertions(+), 34 deletions(-) create mode 100644 README create mode 100644 VERSION diff --git a/Makefile b/Makefile index 10333b68..1217f916 100644 --- a/Makefile +++ b/Makefile @@ -9,9 +9,8 @@ LIBDIR=$(PREFIX)/lib INCDIR=$(PREFIX)/include/chibi-scheme MODDIR=$(PREFIX)/share/chibi-scheme -SO=.dylib LDFLAGS=-lm -CFLAGS=-Wall -g -save-temps -Os +CFLAGS=-Wall -g -Os GC_OBJ=./gc/gc.a @@ -27,12 +26,6 @@ eval.o: eval.c debug.c opcodes.c eval.h sexp.h config.h defaults.h Makefile main.o: main.c eval.c debug.c opcodes.c eval.h sexp.h config.h defaults.h Makefile gcc -c $(CPPFLAGS) $(CFLAGS) -o $@ $< -libchibisexp.$(SO): sexp.o $(GC_OBJ) - gcc $(LDFLAGS) -shared -dynamiclib -o $@ $^ - -libchibischeme.$(SO): eval.o $(GC_OBJ) - gcc $(LDFLAGS) -shared -dynamiclib -o $@ $^ -lchibisexp - chibi-scheme: main.o sexp.o $(GC_OBJ) gcc $(CFLAGS) $(LDFLAGS) -o $@ $^ @@ -52,18 +45,25 @@ test: chibi-scheme echo "[FAIL] $${f%.scm}"; \ fi; \ done + ./chibi-scheme -l syntax-rules.scm tests/r5rs-tests.scm -install: chibi-scheme - cp chibi-scheme $(BINDIR)/ - mkdir -p $(MODDIR) - cp init.scm $(MODDIR)/ - mkdir -p $(INCDIR) - cp *.h $(INCDIR)/ - cp *.$(SO) $(LIBDIR)/ +# install: chibi-scheme +# cp chibi-scheme $(BINDIR)/ +# mkdir -p $(MODDIR) +# cp init.scm $(MODDIR)/ +# mkdir -p $(INCDIR) +# cp *.h $(INCDIR)/ +# cp *.$(SO) $(LIBDIR)/ -uninstall: - rm -f $(BINDIR)/chibi-scheme - rm -f $(LIBDIR)/libchibischeme.$(SO) - rm -f $(LIBDIR)/libchibisexp.$(SO) - rm -f $(INCDIR)/*.h - rm -f $(MODDIR)/*.scm +# uninstall: +# rm -f $(BINDIR)/chibi-scheme +# rm -f $(LIBDIR)/libchibischeme.$(SO) +# rm -f $(LIBDIR)/libchibisexp.$(SO) +# rm -f $(INCDIR)/*.h +# rm -f $(MODDIR)/*.scm + +dist: cleaner + mkdir chibi-scheme-`cat VERSION` + for f in `hg manifest`; do mkdir -p chibi-scheme-`cat VERSION`/`dirname $$f`; ln -s $$f chibi-scheme-`cat VERSION`/$$f; done + tar cphzvf chibi-scheme-`cat VERSION`.tar.gz chibi-scheme-`cat VERSION` + rm -rf chibi-scheme-`cat VERSION` diff --git a/README b/README new file mode 100644 index 00000000..0372dfa2 --- /dev/null +++ b/README @@ -0,0 +1,26 @@ + + Chibi-Scheme + -------------- + + Simple and Minimal Scheme Implementation + + http://synthcode.com/scheme/chibi-scheme/ + + version 0.1 + April 8, 2009 + + +Chibi-Scheme is a very small but mostly complete R5RS Scheme +implementation using a reasonably fast custom VM. Chibi-Scheme tries +as much as possible not to trade its small size by cutting corners, +and provides full continuations, both low and high-level hygienic +macros based on syntactic-closures, and string ports and exceptions. +Chibi-Scheme is written in highly portable C and supports multiple +simultaneous VM instances to run. + +To build, just run "make". You can edit the file config.h for a +number of settings, mostly disabling features to make the executable +smaller. Documents and examples for using Chibi-Scheme as a library +for extension scripting will be provided in an upcoming release. + +syntax-rules must be loaded manually from the file syntax-rules.scm. diff --git a/VERSION b/VERSION new file mode 100644 index 00000000..49d59571 --- /dev/null +++ b/VERSION @@ -0,0 +1 @@ +0.1 diff --git a/debug.c b/debug.c index 299b20cc..f39ba635 100644 --- a/debug.c +++ b/debug.c @@ -3,8 +3,9 @@ /* BSD-style license: http://synthcode.com/license.txt */ static const char* reverse_opcode_names[] = - {"NOOP", "ERROR", "RESUMECC", "CALLCC", "APPLY1", "TAIL-CALL", "CALL", - "FCALL0", "FCALL1", "FCALL2", "FCALL3", "FCALL4", "EVAL", "JUMP-UNLESS", + {"NOOP", "RAISE", "RESUMECC", "CALLCC", "APPLY1", "TAIL-CALL", "CALL", + "FCALL0", "FCALL1", "FCALL2", "FCALL3", "FCALL4", "FCALL5", "FCALL6", + "EVAL", "JUMP-UNLESS", "JUMP", "PUSH", "DROP", "GLOBAL-REF", "GLOBAL-KNOWN-REF", "STACK-REF", "LOCAL-REF", "LOCAL-SET", "CLOSURE-REF", "VECTOR-REF", "VECTOR-SET", "VECTOR-LENGTH", "STRING-REF", diff --git a/defaults.h b/defaults.h index 949c117e..add20406 100644 --- a/defaults.h +++ b/defaults.h @@ -52,6 +52,10 @@ #define USE_FAST_LET 1 #endif +#ifndef USE_CHECK_STACK +#define USE_CHECK_STACK 0 +#endif + #if USE_BOEHM #include "gc/include/gc.h" #define sexp_alloc GC_malloc diff --git a/eval.c b/eval.c index 8d3faadb..a5c57ca8 100644 --- a/eval.c +++ b/eval.c @@ -989,6 +989,7 @@ static sexp_uint_t sexp_restore_stack(sexp saved, sexp *current) { #define _ARG3 stack[top-3] #define _ARG4 stack[top-4] #define _ARG5 stack[top-5] +#define _ARG6 stack[top-6] #define _PUSH(x) (stack[top++]=(x)) #define _WORD0 ((sexp*)ip)[0] #define _UWORD0 ((sexp_uint_t*)ip)[0] @@ -1020,7 +1021,7 @@ sexp vm (sexp self, sexp context, sexp* stack, sexp_sint_t top) { switch (*ip++) { case OP_NOOP: break; - case OP_ERROR: + case OP_RAISE: call_error_handler: stack[top] = (sexp) 1; stack[top+1] = sexp_make_integer(ip); @@ -1087,8 +1088,10 @@ sexp vm (sexp self, sexp context, sexp* stack, sexp_sint_t top) { fp = sexp_unbox_integer(tmp2); goto make_call; case OP_CALL: +#if USE_CHECK_STACK if (top >= INIT_STACK_SIZE) sexp_raise("out of stack space", SEXP_NULL); +#endif i = sexp_unbox_integer(_WORD0); tmp1 = _ARG1; make_call: @@ -1164,6 +1167,18 @@ sexp vm (sexp self, sexp context, sexp* stack, sexp_sint_t top) { ip += sizeof(sexp); sexp_check_exception(); break; + case OP_FCALL5: + _ARG5 =((sexp_proc5)_UWORD0)(_ARG1, _ARG2, _ARG3, _ARG4, _ARG5); + top -= 4; + ip += sizeof(sexp); + sexp_check_exception(); + break; + case OP_FCALL6: + _ARG6 =((sexp_proc6)_UWORD0)(_ARG1, _ARG2, _ARG3, _ARG4, _ARG5, _ARG6); + top -= 5; + ip += sizeof(sexp); + sexp_check_exception(); + break; case OP_EVAL: sexp_context_top(context) = top; _ARG1 = eval_in_context(_ARG1, context); @@ -1534,6 +1549,13 @@ sexp vm (sexp self, sexp context, sexp* stack, sexp_sint_t top) { /************************ library procedures **************************/ +static sexp sexp_exception_type_func (sexp exn) { + if (sexp_exceptionp(exn)) + return sexp_exception_kind(exn); + else + return sexp_type_exception("not an exception", exn); +} + static sexp sexp_open_input_file (sexp path) { FILE *in; if (! sexp_stringp(path)) return sexp_type_exception("not a string", path); @@ -1800,8 +1822,8 @@ void scheme_init () { if (! scheme_initialized_p) { scheme_initialized_p = 1; sexp_init(); - the_compile_error_symbol = sexp_intern("compile-error"); - the_err_handler_symbol = sexp_intern("*current-error-handler*"); + the_compile_error_symbol = sexp_intern("compile"); + the_err_handler_symbol = sexp_intern("*current-exception-handler*"); the_cur_in_symbol = sexp_intern("*current-input-port*"); the_cur_out_symbol = sexp_intern("*current-output-port*"); the_cur_err_symbol = sexp_intern("*current-error-port*"); diff --git a/eval.h b/eval.h index 8e42e3bf..2e16def8 100644 --- a/eval.h +++ b/eval.h @@ -24,7 +24,6 @@ typedef sexp (*sexp_proc3) (sexp, sexp, sexp); typedef sexp (*sexp_proc4) (sexp, sexp, sexp, sexp); typedef sexp (*sexp_proc5) (sexp, sexp, sexp, sexp, sexp); typedef sexp (*sexp_proc6) (sexp, sexp, sexp, sexp, sexp, sexp); -typedef sexp (*sexp_proc7) (sexp, sexp, sexp, sexp, sexp, sexp, sexp); enum core_form_names { CORE_DEFINE = 1, @@ -54,7 +53,7 @@ enum opcode_classes { enum opcode_names { OP_NOOP, - OP_ERROR, + OP_RAISE, OP_RESUMECC, OP_CALLCC, OP_APPLY1, @@ -65,6 +64,8 @@ enum opcode_names { OP_FCALL2, OP_FCALL3, OP_FCALL4, + OP_FCALL5, + OP_FCALL6, OP_EVAL, OP_JUMP_UNLESS, OP_JUMP, diff --git a/init.scm b/init.scm index 17f3ad5d..24d73783 100644 --- a/init.scm +++ b/init.scm @@ -264,6 +264,16 @@ (define (force x) (if (procedure? x) (x) x)) +(define (error msg . args) + (raise (make-exception 'user msg args #f #f #f))) + +(define (with-exception-handler handler thunk) + (let ((orig-handler (current-exception-handler))) + (current-exception-handler handler) + (let ((res (thunk))) + (current-exception-handler orig-handler) + res))) + ;; booleans (define (not x) (if x #f #t)) diff --git a/opcodes.c b/opcodes.c index aaa990ae..c0a9c93b 100644 --- a/opcodes.c +++ b/opcodes.c @@ -9,6 +9,8 @@ #define _FN2OPT(t, u, s, f, d) _FN(OP_FCALL2, 1, 1, t, u, s, f, d) #define _FN3(t, u, s, f, d) _FN(OP_FCALL3, 3, 0, t, u, s, f, d) #define _FN4(t, u, s, f, d) _FN(OP_FCALL4, 4, 0, t, u, s, f, d) +#define _FN5(t, u, s, f, d) _FN(OP_FCALL5, 5, 0, t, u, s, f, d) +#define _FN6(t, u, s, f, d) _FN(OP_FCALL6, 6, 0, t, u, s, f, d) #define _PARAM(n, a, t) _OP(OPC_PARAMETER, OP_NOOP, 0, 3, t, 0, 0, n, a, 0) static struct sexp_struct opcodes[] = { @@ -58,7 +60,7 @@ _OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "input-port?", 0, (sexp)SEXP_I _OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "output-port?", 0, (sexp)SEXP_OPORT), _OP(OPC_GENERIC, OP_APPLY1, 2, 0, SEXP_PROCEDURE, SEXP_PAIR, 0, "apply1", 0, NULL), _OP(OPC_GENERIC, OP_CALLCC, 1, SEXP_PROCEDURE, 0, 0, 0, "call-with-current-continuation", 0, NULL), -_OP(OPC_GENERIC, OP_ERROR, 1, SEXP_STRING, 0, 0, 0, "error", 0, NULL), +_OP(OPC_GENERIC, OP_RAISE, 1, SEXP_STRING, 0, 0, 0, "raise", 0, NULL), _OP(OPC_IO, OP_WRITE, 1, 3, 0, SEXP_OPORT, 0, "write", (sexp)"*current-output-port*", NULL), _OP(OPC_IO, OP_DISPLAY, 1, 3, 0, SEXP_OPORT, 0, "display", (sexp)"*current-output-port*", NULL), _OP(OPC_IO, OP_WRITE_CHAR, 1, 3, 0, SEXP_OPORT, 0, "write-char", (sexp)"*current-output-port*", NULL), @@ -83,6 +85,8 @@ _FN1(SEXP_FIXNUM, "null-environment", 0, sexp_make_null_env), _FN1(SEXP_FIXNUM, "scheme-report-environment", 0, sexp_make_standard_env), _FN2(SEXP_STRING, SEXP_ENV, "%load", 0, sexp_load), _FN2(SEXP_EXCEPTION, SEXP_OPORT, "print-exception", 0, sexp_print_exception), +_FN1(SEXP_EXCEPTION, "exception-type", 0, sexp_exception_type_func), +_FN6(SEXP_SYMBOL, SEXP_STRING, "make-exception", 0, sexp_make_exception), _FN2OPT(SEXP_FIXNUM, SEXP_CHAR, "make-string", sexp_make_character(' '), sexp_make_string), _FN2(SEXP_STRING, SEXP_STRING, "string-cmp", 0, sexp_string_cmp), _FN2(SEXP_STRING, SEXP_STRING, "string-cmp-ci", 0, sexp_string_cmp_ci), @@ -95,7 +99,7 @@ _FN3(SEXP_ENV, SEXP_PAIR, "make-syntactic-closure", 0, sexp_make_synclo), _PARAM("current-input-port", (sexp)"*current-input-port*", SEXP_IPORT), _PARAM("current-output-port", (sexp)"*current-output-port*", SEXP_OPORT), _PARAM("current-error-port", (sexp)"*current-error-port*", SEXP_OPORT), -_PARAM("current-error-handler", (sexp)"*current-error-handler*", SEXP_PROCEDURE), +_PARAM("current-exception-handler", (sexp)"*current-exception-handler*", SEXP_PROCEDURE), _PARAM("interaction-environment", (sexp)"*interaction-environment*", SEXP_ENV), #if USE_MATH _FN1(0, "exp", 0, sexp_exp), diff --git a/sexp.c b/sexp.c index 4b8e0ce5..3647261c 100644 --- a/sexp.c +++ b/sexp.c @@ -104,7 +104,7 @@ sexp sexp_make_exception (sexp kind, sexp message, sexp irritants, } sexp sexp_user_exception (sexp self, char *message, sexp irritants) { - return sexp_make_exception(sexp_intern("user-error"), + return sexp_make_exception(sexp_intern("user"), sexp_c_string(message), ((sexp_pairp(irritants) || sexp_nullp(irritants)) ? irritants : sexp_list1(irritants)), @@ -112,13 +112,13 @@ sexp sexp_user_exception (sexp self, char *message, sexp irritants) { } sexp sexp_type_exception (char *message, sexp obj) { - return sexp_make_exception(sexp_intern("type-error"), + return sexp_make_exception(sexp_intern("type"), sexp_c_string(message), sexp_list1(obj), SEXP_FALSE, SEXP_FALSE, SEXP_FALSE); } sexp sexp_range_exception (sexp obj, sexp start, sexp end) { - return sexp_make_exception(sexp_intern("range-error"), + return sexp_make_exception(sexp_intern("range"), sexp_c_string("bad index range"), sexp_list3(obj, start, end), SEXP_FALSE, SEXP_FALSE, SEXP_FALSE); @@ -1135,7 +1135,7 @@ void sexp_init() { 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_read_error_symbol = sexp_intern("read"); the_empty_vector = sexp_alloc_type(vector, SEXP_VECTOR); sexp_vector_length(the_empty_vector) = 0; sexp_vector_data(the_empty_vector) = NULL; From 3533043f71aa7bfff5fee4515fafd596e2ac4ed9 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 9 Apr 2009 00:57:53 +0900 Subject: [PATCH 103/154] about to release --- Makefile | 6 ++++-- README | 5 +++-- 2 files changed, 7 insertions(+), 4 deletions(-) diff --git a/Makefile b/Makefile index 1217f916..2c226c7e 100644 --- a/Makefile +++ b/Makefile @@ -63,7 +63,9 @@ test: chibi-scheme # rm -f $(MODDIR)/*.scm dist: cleaner + rm -f chibi-scheme-`cat VERSION`.tgz mkdir chibi-scheme-`cat VERSION` - for f in `hg manifest`; do mkdir -p chibi-scheme-`cat VERSION`/`dirname $$f`; ln -s $$f chibi-scheme-`cat VERSION`/$$f; done - tar cphzvf chibi-scheme-`cat VERSION`.tar.gz chibi-scheme-`cat VERSION` + for f in `hg manifest`; do mkdir -p chibi-scheme-`cat VERSION`/`dirname $$f`; ln -s `pwd`/$$f chibi-scheme-`cat VERSION`/$$f; done + cd chibi-scheme-`cat VERSION`; tar xzvf ../gc.tar.gz; mv gc[0-9].[0-9] gc + tar cphzvf chibi-scheme-`cat VERSION`.tgz chibi-scheme-`cat VERSION` rm -rf chibi-scheme-`cat VERSION` diff --git a/README b/README index 0372dfa2..ea9fdc82 100644 --- a/README +++ b/README @@ -4,7 +4,7 @@ Simple and Minimal Scheme Implementation - http://synthcode.com/scheme/chibi-scheme/ + http://synthcode.com/scheme/chibi-scheme-0.1.tgz version 0.1 April 8, 2009 @@ -16,7 +16,8 @@ as much as possible not to trade its small size by cutting corners, and provides full continuations, both low and high-level hygienic macros based on syntactic-closures, and string ports and exceptions. Chibi-Scheme is written in highly portable C and supports multiple -simultaneous VM instances to run. +simultaneous VM instances to run. Currently Chibi-Scheme uses the +Boehm conservative garbage collector to try to play well with C code. To build, just run "make". You can edit the file config.h for a number of settings, mostly disabling features to make the executable From b5f07e6da674fc3368746305706e8078ea5e2740 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 14 Apr 2009 21:28:21 +0900 Subject: [PATCH 104/154] fixing syntax-rules.scm --- .hgignore | 19 + Makefile | 71 + README | 27 + VERSION | 1 + config.h | 31 + debug.c | 73 + defaults.h | 73 + eval.c | 1854 ++++++++++++++++++++++++ eval.h | 137 ++ init.scm | 525 +++++++ main.c | 110 ++ opcodes.c | 130 ++ sexp-huff.c | 128 ++ sexp-hufftabs.c | 92 ++ sexp-unhuff.c | 71 + sexp.c | 1147 +++++++++++++++ sexp.h | 441 ++++++ syntax-rules.scm | 182 +++ tests/basic/test00-fact-3.res | 1 + tests/basic/test00-fact-3.scm | 14 + tests/basic/test01-apply.res | 8 + tests/basic/test01-apply.scm | 18 + tests/basic/test02-closure.res | 6 + tests/basic/test02-closure.scm | 16 + tests/basic/test03-nested-closure.res | 1 + tests/basic/test03-nested-closure.scm | 8 + tests/basic/test04-nested-let.res | 1 + tests/basic/test04-nested-let.scm | 9 + tests/basic/test05-internal-define.res | 1 + tests/basic/test05-internal-define.scm | 8 + tests/basic/test06-letrec.res | 4 + tests/basic/test06-letrec.scm | 15 + tests/basic/test07-mutation.res | 1 + tests/basic/test07-mutation.scm | 9 + tests/basic/test08-callcc.res | 1 + tests/basic/test08-callcc.scm | 34 + tests/basic/test09-hygiene.res | 5 + tests/basic/test09-hygiene.scm | 25 + tests/basic/test10-unhygiene.res | 6 + tests/basic/test10-unhygiene.scm | 49 + tests/r5rs-tests.scm | 373 +++++ 41 files changed, 5725 insertions(+) create mode 100644 .hgignore create mode 100644 Makefile create mode 100644 README create mode 100644 VERSION create mode 100644 config.h create mode 100644 debug.c create mode 100644 defaults.h create mode 100644 eval.c create mode 100644 eval.h create mode 100644 init.scm create mode 100644 main.c create mode 100644 opcodes.c create mode 100644 sexp-huff.c create mode 100644 sexp-hufftabs.c create mode 100644 sexp-unhuff.c create mode 100644 sexp.c create mode 100644 sexp.h create mode 100644 syntax-rules.scm create mode 100644 tests/basic/test00-fact-3.res create mode 100644 tests/basic/test00-fact-3.scm create mode 100644 tests/basic/test01-apply.res create mode 100644 tests/basic/test01-apply.scm create mode 100644 tests/basic/test02-closure.res create mode 100644 tests/basic/test02-closure.scm create mode 100644 tests/basic/test03-nested-closure.res create mode 100644 tests/basic/test03-nested-closure.scm create mode 100644 tests/basic/test04-nested-let.res create mode 100644 tests/basic/test04-nested-let.scm create mode 100644 tests/basic/test05-internal-define.res create mode 100644 tests/basic/test05-internal-define.scm create mode 100644 tests/basic/test06-letrec.res create mode 100644 tests/basic/test06-letrec.scm create mode 100644 tests/basic/test07-mutation.res create mode 100644 tests/basic/test07-mutation.scm create mode 100644 tests/basic/test08-callcc.res create mode 100644 tests/basic/test08-callcc.scm create mode 100644 tests/basic/test09-hygiene.res create mode 100644 tests/basic/test09-hygiene.scm create mode 100644 tests/basic/test10-unhygiene.res create mode 100644 tests/basic/test10-unhygiene.scm create mode 100644 tests/r5rs-tests.scm diff --git a/.hgignore b/.hgignore new file mode 100644 index 00000000..51566e20 --- /dev/null +++ b/.hgignore @@ -0,0 +1,19 @@ +syntax: glob +*~ +*.i +*.s +*.o +*.so +*.dSYM +*.orig +.hg +junk* +*.tar.gz +*.tar.bz2 +*.log +*.err +*.out +gc +gc6.8 +chibi-scheme + diff --git a/Makefile b/Makefile new file mode 100644 index 00000000..c4166b8d --- /dev/null +++ b/Makefile @@ -0,0 +1,71 @@ + +.PHONY: all doc dist clean cleaner test install uninstall + +all: chibi-scheme + +PREFIX=/usr/local +BINDIR=$(PREFIX)/bin +LIBDIR=$(PREFIX)/lib +INCDIR=$(PREFIX)/include/chibi-scheme +MODDIR=$(PREFIX)/share/chibi-scheme + +LDFLAGS=-lm +CFLAGS=-Wall -g -Os + +GC_OBJ=./gc/gc.a + +./gc/gc.a: ./gc/alloc.c + cd gc && make + +sexp.o: sexp.c sexp.h config.h defaults.h Makefile + gcc -c $(CPPFLAGS) $(CFLAGS) -o $@ $< + +eval.o: eval.c debug.c opcodes.c eval.h sexp.h config.h defaults.h Makefile + gcc -c $(CPPFLAGS) $(CFLAGS) -o $@ $< + +main.o: main.c eval.c debug.c opcodes.c eval.h sexp.h config.h defaults.h Makefile + gcc -c $(CPPFLAGS) $(CFLAGS) -o $@ $< + +chibi-scheme: main.o sexp.o $(GC_OBJ) + gcc $(CFLAGS) $(LDFLAGS) -o $@ $^ + +clean: + rm -f *.o *.i *.s + +cleaner: clean + rm -f chibi-scheme + rm -rf *.dSYM + +test: chibi-scheme + @for f in tests/basic/*.scm; do \ + ./chibi-scheme $$f >$${f%.scm}.out 2>$${f%.scm}.err; \ + if diff -q $${f%.scm}.out $${f%.scm}.res; then \ + echo "[PASS] $${f%.scm}"; \ + else \ + echo "[FAIL] $${f%.scm}"; \ + fi; \ + done + ./chibi-scheme -l syntax-rules.scm tests/r5rs-tests.scm + +# install: chibi-scheme +# cp chibi-scheme $(BINDIR)/ +# mkdir -p $(MODDIR) +# cp init.scm $(MODDIR)/ +# mkdir -p $(INCDIR) +# cp *.h $(INCDIR)/ +# cp *.$(SO) $(LIBDIR)/ + +# uninstall: +# rm -f $(BINDIR)/chibi-scheme +# rm -f $(LIBDIR)/libchibischeme.$(SO) +# rm -f $(LIBDIR)/libchibisexp.$(SO) +# rm -f $(INCDIR)/*.h +# rm -f $(MODDIR)/*.scm + +dist: cleaner + rm -f chibi-scheme-`cat VERSION`.tgz + mkdir chibi-scheme-`cat VERSION` + for f in `hg manifest`; do mkdir -p chibi-scheme-`cat VERSION`/`dirname $$f`; ln -s `pwd`/$$f chibi-scheme-`cat VERSION`/$$f; done + cd chibi-scheme-`cat VERSION`; tar xzvf ../gc.tar.gz; mv gc[0-9].[0-9] gc + tar cphzvf chibi-scheme-`cat VERSION`.tgz chibi-scheme-`cat VERSION` + rm -rf chibi-scheme-`cat VERSION` diff --git a/README b/README new file mode 100644 index 00000000..e4eb9abc --- /dev/null +++ b/README @@ -0,0 +1,27 @@ + + Chibi-Scheme + -------------- + + Simple and Minimal Scheme Implementation + + http://synthcode.com/scheme/chibi-scheme-0.1.tgz + + version 0.1 + April 8, 2009 + + +Chibi-Scheme is a very small but mostly complete R5RS Scheme +implementation using a reasonably fast custom VM. Chibi-Scheme tries +as much as possible not to trade its small size by cutting corners, +and provides full continuations, both low and high-level hygienic +macros based on syntactic-closures, string ports and exceptions. +Chibi-Scheme is written in highly portable C and supports multiple +simultaneous VM instances to run. Currently Chibi-Scheme uses the +Boehm conservative garbage collector to try to play well with C code. + +To build, just run "make". You can edit the file config.h for a +number of settings, mostly disabling features to make the executable +smaller. Documents and examples for using Chibi-Scheme as a library +for extension scripting will be provided in an upcoming release. + +syntax-rules must be loaded manually from the file syntax-rules.scm. diff --git a/VERSION b/VERSION new file mode 100644 index 00000000..49d59571 --- /dev/null +++ b/VERSION @@ -0,0 +1 @@ +0.1 diff --git a/config.h b/config.h new file mode 100644 index 00000000..81f1444c --- /dev/null +++ b/config.h @@ -0,0 +1,31 @@ +/* config.h -- general configuration */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +/* uncomment this to use manual memory management */ +/* #define USE_BOEHM 0 */ + +/* uncomment this if you only want fixnum support */ +/* #define USE_FLONUMS 0 */ + +/* uncomment this if you don't need extended math operations */ +/* #define USE_MATH 0 */ + +/* uncomment this to disable warning about references to undefined variables */ +/* #define USE_WARN_UNDEFS 0 */ + +/* uncomment this to disable huffman-coded immediate symbols */ +/* #define USE_HUFF_SYMS 0 */ + +/* uncomment this to just use a single list for hash tables */ +/* #define USE_HASH_SYMS 0 */ + +/* uncomment this to disable string ports */ +/* #define USE_STRING_STREAMS 0 */ + +/* uncomment this to disable a small optimization for let */ +/* #define USE_FAST_LET 0 */ + +/* uncomment this to enable debugging utilities */ +/* #define USE_DEBUG 1 */ + diff --git a/debug.c b/debug.c new file mode 100644 index 00000000..f39ba635 --- /dev/null +++ b/debug.c @@ -0,0 +1,73 @@ +/* debug.c -- optional debugging utilities */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +static const char* reverse_opcode_names[] = + {"NOOP", "RAISE", "RESUMECC", "CALLCC", "APPLY1", "TAIL-CALL", "CALL", + "FCALL0", "FCALL1", "FCALL2", "FCALL3", "FCALL4", "FCALL5", "FCALL6", + "EVAL", "JUMP-UNLESS", + "JUMP", "PUSH", "DROP", "GLOBAL-REF", "GLOBAL-KNOWN-REF", "STACK-REF", + "LOCAL-REF", "LOCAL-SET", + "CLOSURE-REF", "VECTOR-REF", "VECTOR-SET", "VECTOR-LENGTH", "STRING-REF", + "STRING-SET", "STRING-LENGTH", "MAKE-PROCEDURE", "MAKE-VECTOR", "AND", + "NULL?", "FIXNUM?", "SYMBOL?", "CHAR?", + "EOF?", "TYPEP", "CAR", "CDR", "SET-CAR", "SET-CDR", "CONS", "ADD", "SUB", + "MUL", "DIV", "QUOTIENT", "REMAINDER", "NEGATIVE", "INVERSE", + "LT", "LE", "EQN", "EQ", + "EXACT->INEXACT", "INEXACT->EXACT", + "CHAR->INTEGER", "INTEGER->CHAR", "CHAR-UPCASE", "CHAR-DOWNCASE", + "DISPLAY", "WRITE", "WRITE-CHAR", + "NEWLINE", "FLUSH-OUTPUT", "READ", "READ-CHAR", "PEEK-CHAR", "RET", "DONE", + }; + +static sexp sexp_disasm (sexp bc, sexp out) { + unsigned char *ip, opcode; + if (sexp_procedurep(bc)) + bc = sexp_procedure_code(bc); + ip = sexp_bytecode_data(bc); + loop: + opcode = *ip++; + if (opcode*sizeof(char*) < sizeof(reverse_opcode_names)) { + sexp_printf(out, " %s ", reverse_opcode_names[opcode]); + } else { + sexp_printf(out, " %d ", opcode); + } + switch (opcode) { + case OP_STACK_REF: + case OP_LOCAL_REF: + case OP_LOCAL_SET: + case OP_CLOSURE_REF: + case OP_JUMP: + case OP_JUMP_UNLESS: + case OP_FCALL0: + case OP_FCALL1: + case OP_FCALL2: + case OP_FCALL3: + case OP_TYPEP: + sexp_printf(out, "%ld", (sexp_sint_t) ((sexp*)ip)[0]); + ip += sizeof(sexp); + break; + case OP_GLOBAL_REF: + case OP_GLOBAL_KNOWN_REF: + case OP_TAIL_CALL: + case OP_CALL: + case OP_PUSH: + sexp_write(((sexp*)ip)[0], out); + ip += sizeof(sexp); + break; + } + sexp_write_char('\n', out); + if (ip - sexp_bytecode_data(bc) < sexp_bytecode_length(bc)) + goto loop; + return SEXP_VOID; +} + +static void sexp_print_stack (sexp *stack, int top, int fp, sexp out) { + int i; + for (i=0; i +#else +/* requires msg be a string literal, and at least one argument */ +#define errx(code, msg, ...) (fprintf(stderr,msg"\n",__VA_ARGS__), exit(code)) +#endif + +#if defined(__APPLE__) || defined(__FreeBSD__) || defined(__NetBSD__) || defined(__DragonFly__) || defined(__OpenBSD__) +#define SEXP_BSD 1 +#else +#define SEXP_BSD 0 +#define _GNU_SOURCE +#endif + +#ifndef USE_BOEHM +#define USE_BOEHM 1 +#endif + +#ifndef USE_FLONUMS +#define USE_FLONUMS 1 +#endif + +#ifndef USE_MATH +#define USE_MATH 1 +#endif + +#ifndef USE_WARN_UNDEFS +#define USE_WARN_UNDEFS 1 +#endif + +#ifndef USE_HUFF_SYMS +#define USE_HUFF_SYMS 1 +#endif + +#ifndef USE_HASH_SYMS +#define USE_HASH_SYMS 1 +#endif + +#ifndef USE_DEBUG +#define USE_DEBUG 1 +#endif + +#ifndef USE_STRING_STREAMS +#define USE_STRING_STREAMS 1 +#endif + +#ifndef USE_FAST_LET +#define USE_FAST_LET 1 +#endif + +#ifndef USE_CHECK_STACK +#define USE_CHECK_STACK 0 +#endif + +#if USE_BOEHM +#include "gc/include/gc.h" +#define sexp_alloc GC_malloc +#define sexp_alloc_atomic GC_malloc_atomic +#define sexp_realloc GC_realloc +#define sexp_free(x) +#define sexp_deep_free(x) +#else +#define sexp_alloc malloc +#define sexp_alloc_atomic sexp_alloc +#define sexp_realloc realloc +#define sexp_free free +void sexp_deep_free(sexp obj); +#endif + diff --git a/eval.c b/eval.c new file mode 100644 index 00000000..28cc7b61 --- /dev/null +++ b/eval.c @@ -0,0 +1,1854 @@ +/* eval.c -- evaluator library implementation */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include "eval.h" + +/************************************************************************/ + +static int scheme_initialized_p = 0; + +static sexp continuation_resumer, final_resumer; +static sexp the_interaction_env_symbol; +static sexp the_err_handler_symbol, the_compile_error_symbol; +static sexp the_cur_in_symbol, the_cur_out_symbol, the_cur_err_symbol; + +#if USE_DEBUG +#include "debug.c" +#else +#define print_stack(...) +#define print_bytecode(...) +#define sexp_disasm(...) +#endif + +static sexp analyze (sexp x, sexp context); +static void generate (sexp x, sexp context); +static sexp sexp_make_null_env (sexp version); +static sexp sexp_make_standard_env (sexp version); + +/********************** environment utilities ***************************/ + +static sexp env_cell(sexp e, sexp key) { + sexp ls; + + do { + for (ls=sexp_env_bindings(e); sexp_pairp(ls); ls=sexp_cdr(ls)) + if (sexp_caar(ls) == key) + return sexp_car(ls); + e = sexp_env_parent(e); + } while (e); + + return NULL; +} + +static sexp env_cell_create(sexp e, sexp key, sexp value) { + sexp cell = env_cell(e, key); + if (! cell) { + cell = sexp_cons(key, value); + while (sexp_env_parent(e)) + e = sexp_env_parent(e); + sexp_env_bindings(e) = sexp_cons(cell, sexp_env_bindings(e)); + } + return cell; +} + +static sexp env_global_ref(sexp e, sexp key, sexp dflt) { + sexp cell; + while (sexp_env_parent(e)) + e = sexp_env_parent(e); + cell = env_cell(e, key); + return (cell ? sexp_cdr(cell) : dflt); +} + +static void env_define(sexp e, sexp key, sexp value) { + sexp cell = sexp_assq(key, sexp_env_bindings(e)); + if (cell != SEXP_FALSE) + sexp_cdr(cell) = value; + else + sexp_push(sexp_env_bindings(e), sexp_cons(key, value)); +} + +static sexp extend_env (sexp env, sexp vars, sexp value) { + sexp e = sexp_alloc_type(env, SEXP_ENV); + sexp_env_parent(e) = env; + sexp_env_bindings(e) = SEXP_NULL; + for ( ; sexp_pairp(vars); vars = sexp_cdr(vars)) + sexp_push(sexp_env_bindings(e), sexp_cons(sexp_car(vars), value)); + return e; +} + +static sexp sexp_reverse_flatten_dot (sexp ls) { + sexp res; + for (res=SEXP_NULL; sexp_pairp(ls); ls=sexp_cdr(ls)) + sexp_push(res, sexp_car(ls)); + return (sexp_nullp(ls) ? res : sexp_cons(ls, res)); +} + +static sexp sexp_flatten_dot (sexp ls) { + return sexp_nreverse(sexp_reverse_flatten_dot(ls)); +} + +static int sexp_param_index (sexp lambda, sexp name) { + sexp ls = sexp_lambda_params(lambda); + int i = 0; + for (i=0; sexp_pairp(ls); ls=sexp_cdr(ls), i++) + if (sexp_car(ls) == name) + return i; + if (ls == name) + return i; + ls = sexp_lambda_locals(lambda); + for (i=-1; sexp_pairp(ls); ls=sexp_cdr(ls), i--) + if (sexp_car(ls) == name) + return i-4; + return -10000; +} + +/************************* bytecode utilities ***************************/ + +static void shrink_bcode(sexp context, sexp_uint_t i) { + sexp tmp; + if (sexp_bytecode_length(sexp_context_bc(context)) != i) { + tmp = sexp_alloc_tagged(sexp_sizeof(bytecode) + i, SEXP_BYTECODE); + sexp_bytecode_name(tmp) = SEXP_FALSE; + sexp_bytecode_length(tmp) = i; + sexp_bytecode_literals(tmp) + = sexp_bytecode_literals(sexp_context_bc(context)); + memcpy(sexp_bytecode_data(tmp), + sexp_bytecode_data(sexp_context_bc(context)), + i); + sexp_context_bc(context) = tmp; + } +} + +static void expand_bcode(sexp context, sexp_uint_t size) { + sexp tmp; + if (sexp_bytecode_length(sexp_context_bc(context)) + < (sexp_context_pos(context))+size) { + tmp = sexp_alloc_tagged(sexp_sizeof(bytecode) + + sexp_bytecode_length(sexp_context_bc(context))*2, + SEXP_BYTECODE); + sexp_bytecode_name(tmp) = SEXP_FALSE; + sexp_bytecode_length(tmp) + = sexp_bytecode_length(sexp_context_bc(context))*2; + sexp_bytecode_literals(tmp) + = sexp_bytecode_literals(sexp_context_bc(context)); + memcpy(sexp_bytecode_data(tmp), + sexp_bytecode_data(sexp_context_bc(context)), + sexp_bytecode_length(sexp_context_bc(context))); + sexp_context_bc(context) = tmp; + } +} + +static void emit(char c, sexp context) { + expand_bcode(context, 1); + sexp_bytecode_data(sexp_context_bc(context))[sexp_context_pos(context)++] = c; +} + +static void emit_word(sexp_uint_t val, sexp context) { + unsigned char *data; + expand_bcode(context, sizeof(sexp)); + data = sexp_bytecode_data(sexp_context_bc(context)); + *((sexp_uint_t*)(&(data[sexp_context_pos(context)]))) = val; + sexp_context_pos(context) += sizeof(sexp); +} + +static void emit_push(sexp obj, sexp context) { + emit(OP_PUSH, context); + emit_word((sexp_uint_t)obj, context); + if (sexp_pointerp(obj)) + sexp_push(sexp_bytecode_literals(sexp_context_bc(context)), obj); +} + +static sexp sexp_make_procedure(sexp flags, sexp num_args, + sexp bc, sexp vars) { + sexp proc = sexp_alloc_type(procedure, SEXP_PROCEDURE); + sexp_procedure_flags(proc) = (char) (sexp_uint_t) flags; + sexp_procedure_num_args(proc) = (unsigned short) (sexp_uint_t) num_args; + sexp_procedure_code(proc) = bc; + sexp_procedure_vars(proc) = vars; + return proc; +} + +static sexp sexp_make_macro (sexp p, sexp e) { + sexp mac = sexp_alloc_type(macro, SEXP_MACRO); + sexp_macro_env(mac) = e; + sexp_macro_proc(mac) = p; + return mac; +} + +static sexp sexp_make_synclo (sexp env, sexp fv, sexp expr) { + sexp res; + if (sexp_synclop(expr)) + return expr; + res = sexp_alloc_type(synclo, SEXP_SYNCLO); + sexp_synclo_env(res) = env; + sexp_synclo_free_vars(res) = fv; + sexp_synclo_expr(res) = expr; + return res; +} + +/* internal AST */ + +static sexp sexp_make_lambda(sexp params) { + sexp res = sexp_alloc_type(lambda, SEXP_LAMBDA); + sexp_lambda_name(res) = SEXP_FALSE; + sexp_lambda_params(res) = params; + sexp_lambda_fv(res) = SEXP_NULL; + sexp_lambda_sv(res) = SEXP_NULL; + sexp_lambda_locals(res) = SEXP_NULL; + sexp_lambda_defs(res) = SEXP_NULL; + return res; +} + +static sexp sexp_make_set(sexp var, sexp value) { + sexp res = sexp_alloc_type(set, SEXP_SET); + sexp_set_var(res) = var; + sexp_set_value(res) = value; + return res; +} + +static sexp sexp_make_ref(sexp name, sexp cell) { + sexp res = sexp_alloc_type(ref, SEXP_REF); + sexp_ref_name(res) = name; + sexp_ref_cell(res) = cell; + return res; +} + +static sexp sexp_make_cnd(sexp test, sexp pass, sexp fail) { + sexp res = sexp_alloc_type(cnd, SEXP_CND); + sexp_cnd_test(res) = test; + sexp_cnd_pass(res) = pass; + sexp_cnd_fail(res) = fail; + return res; +} + +static sexp sexp_make_lit(sexp value) { + sexp res = sexp_alloc_type(lit, SEXP_LIT); + sexp_lit_value(res) = value; + return res; +} + +static sexp sexp_make_context(sexp *stack, sexp env) { + sexp res = sexp_alloc_type(context, SEXP_CONTEXT); + if (! stack) + stack = (sexp*) sexp_alloc(sizeof(sexp)*INIT_STACK_SIZE); + if (! env) + env = sexp_make_standard_env(sexp_make_integer(5)); + sexp_context_bc(res) + = sexp_alloc_tagged(sexp_sizeof(bytecode)+INIT_BCODE_SIZE, SEXP_BYTECODE); + sexp_bytecode_name(sexp_context_bc(res)) = SEXP_FALSE; + sexp_bytecode_length(sexp_context_bc(res)) = INIT_BCODE_SIZE; + sexp_bytecode_literals(sexp_context_bc(res)) = SEXP_NULL; + sexp_context_lambda(res) = SEXP_FALSE; + sexp_context_stack(res) = stack; + sexp_context_env(res) = env; + sexp_context_fv(res) = SEXP_NULL; + sexp_context_depth(res) = 0; + sexp_context_pos(res) = 0; + sexp_context_top(res) = 0; + sexp_context_tailp(res) = 0; + sexp_context_tracep(res) = 0; + return res; +} + +static sexp sexp_child_context(sexp context, sexp lambda) { + sexp ctx = sexp_make_context(sexp_context_stack(context), + sexp_context_env(context)); + sexp_context_lambda(ctx) = lambda; + sexp_context_env(ctx) = sexp_context_env(context); + sexp_context_top(ctx) = sexp_context_top(context); + sexp_context_fv(ctx) = sexp_context_fv(context); + sexp_context_tracep(ctx) = sexp_context_tracep(context); + return ctx; +} + +#define sexp_idp(x) (sexp_symbolp(x) || (sexp_synclop(x) && sexp_symbolp(sexp_synclo_expr(x)))) + +static sexp sexp_identifierp (sexp x) { + return sexp_make_boolean(sexp_idp(x)); +} + +static sexp sexp_syntactic_closure_expr (sexp x) { + return (sexp_synclop(x) ? sexp_synclo_expr(x) : x); +} + +static sexp sexp_strip_syntactic_closures (sexp x) { + loop: + if (sexp_synclop(x)) { + x = sexp_synclo_expr(x); + goto loop; + } else if (sexp_pairp(x)) { + return sexp_cons(sexp_strip_syntactic_closures(sexp_car(x)), + sexp_strip_syntactic_closures(sexp_cdr(x))); + } else { + return x; + } +} + +static sexp sexp_identifier_eq (sexp e1, sexp id1, sexp e2, sexp id2) { + sexp cell, lam1=SEXP_FALSE, lam2=SEXP_FALSE; + if (sexp_synclop(id1)) { + e1 = sexp_synclo_env(id1); + id1 = sexp_synclo_expr(id1); + } + if (sexp_synclop(id2)) { + e2 = sexp_synclo_env(id2); + id2 = sexp_synclo_expr(id2); + } + cell = env_cell(e1, id1); + if (cell && sexp_lambdap(sexp_cdr(cell))) + lam1 = sexp_cdr(cell); + cell = env_cell(e2, id2); + if (cell && sexp_lambdap(sexp_cdr(cell))) + lam2 = sexp_cdr(cell); + return sexp_make_boolean((id1 == id2) && (lam1 == lam2)); +} + +/************************* the compiler ***************************/ + +static sexp sexp_compile_error(char *message, sexp irritants) { + return sexp_make_exception(the_compile_error_symbol, + sexp_c_string(message), + irritants, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE); +} + +#define analyze_check_exception(x) do {if (sexp_exceptionp(x)) \ + return (x); \ + } while (0) + +#define analyze_bind(var, x, context) do {(var) = analyze(x,context); \ + analyze_check_exception(var); \ + } while (0) + +static sexp analyze_app (sexp x, sexp context) { + sexp res=SEXP_NULL, tmp; + for ( ; sexp_pairp(x); x=sexp_cdr(x)) { + analyze_bind(tmp, sexp_car(x), context); + sexp_push(res, tmp); + } + return sexp_nreverse(res); +} + +static sexp analyze_seq (sexp ls, sexp context) { + sexp res, tmp; + if (sexp_nullp(ls)) + res = SEXP_VOID; + else if (sexp_nullp(sexp_cdr(ls))) + res = analyze(sexp_car(ls), context); + else { + res = sexp_alloc_type(seq, SEXP_SEQ); + tmp = analyze_app(ls, context); + analyze_check_exception(tmp); + sexp_seq_ls(res) = tmp; + } + return res; +} + +static sexp analyze_var_ref (sexp x, sexp context) { + sexp env = sexp_context_env(context), cell; + cell = env_cell(env, x); + if (! cell) { + if (sexp_synclop(x)) { + if (sexp_memq(x, sexp_context_fv(context)) != SEXP_FALSE) + env = sexp_synclo_env(x); + x = sexp_synclo_expr(x); + } + cell = env_cell_create(env, x, SEXP_UNDEF); + } + if (sexp_macrop(sexp_cdr(cell)) || sexp_corep(sexp_cdr(cell))) + return sexp_compile_error("invalid use of syntax as value", sexp_list1(x)); + return sexp_make_ref(x, cell); +} + +static sexp analyze_set (sexp x, sexp context) { + sexp ref, value; + ref = analyze_var_ref(sexp_cadr(x), context); + if (sexp_lambdap(sexp_ref_loc(ref))) + sexp_insert(sexp_lambda_sv(sexp_ref_loc(ref)), sexp_ref_name(ref)); + analyze_check_exception(ref); + analyze_bind(value, sexp_caddr(x), context); + return sexp_make_set(ref, value); +} + +static sexp analyze_lambda (sexp x, sexp context) { + sexp res, body, ls, tmp, name, value, defs=SEXP_NULL; + /* verify syntax */ + if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) + return sexp_compile_error("bad lambda syntax", sexp_list1(x)); + for (ls=sexp_cadr(x); sexp_pairp(ls); ls=sexp_cdr(ls)) + if (! sexp_idp(sexp_car(ls))) + return sexp_compile_error("non-symbol parameter", sexp_list1(x)); + else if (sexp_memq(sexp_car(ls), sexp_cdr(ls)) != SEXP_FALSE) + return sexp_compile_error("duplicate parameter", sexp_list1(x)); + /* build lambda and analyze body */ + res = sexp_make_lambda(sexp_cadr(x)); + context = sexp_child_context(context, res); + sexp_context_env(context) + = extend_env(sexp_context_env(context), + sexp_flatten_dot(sexp_lambda_params(res)), + res); + sexp_env_lambda(sexp_context_env(context)) = res; + body = analyze_seq(sexp_cddr(x), context); + analyze_check_exception(body); + /* delayed analyze internal defines */ + for (ls=sexp_lambda_defs(res); sexp_pairp(ls); ls=sexp_cdr(ls)) { + tmp = sexp_car(ls); + if (sexp_pairp(sexp_cadr(tmp))) { + name = sexp_caadr(tmp); + value = analyze_lambda(sexp_cons(SEXP_VOID, sexp_cons(sexp_cdadr(tmp), + sexp_cddr(tmp))), + context); + } else { + name = sexp_cadr(tmp); + value = analyze(sexp_caddr(tmp), context); + } + analyze_check_exception(value); + sexp_push(defs, sexp_make_set(analyze_var_ref(name, context), value)); + } + if (sexp_pairp(defs)) { + if (! sexp_seqp(body)) { + tmp = sexp_alloc_type(seq, SEXP_SEQ); + sexp_seq_ls(tmp) = sexp_list1(body); + body = tmp; + } + sexp_seq_ls(body) = sexp_append(defs, sexp_seq_ls(body)); + } + sexp_lambda_body(res) = body; + return res; +} + +static sexp analyze_if (sexp x, sexp context) { + sexp test, pass, fail, fail_expr; + analyze_bind(test, sexp_cadr(x), context); + analyze_bind(pass, sexp_caddr(x), context); + fail_expr = sexp_pairp(sexp_cdddr(x)) ? sexp_cadddr(x) : SEXP_VOID; + analyze_bind(fail, fail_expr, context); + return sexp_make_cnd(test, pass, fail); +} + +static sexp analyze_define (sexp x, sexp context) { + sexp ref, name, value, env = sexp_context_env(context); + name = (sexp_pairp(sexp_cadr(x)) ? sexp_caadr(x) : sexp_cadr(x)); + if (sexp_env_lambda(env) && sexp_lambdap(sexp_env_lambda(env))) { + sexp_push(sexp_env_bindings(env), + sexp_cons(name, sexp_context_lambda(context))); + sexp_push(sexp_lambda_sv(sexp_env_lambda(env)), name); + sexp_push(sexp_lambda_locals(sexp_env_lambda(env)), name); + sexp_push(sexp_lambda_defs(sexp_env_lambda(env)), x); + return SEXP_VOID; + } else { + env_cell_create(env, name, SEXP_VOID); + } + if (sexp_pairp(sexp_cadr(x))) + value = analyze_lambda(sexp_cons(SEXP_VOID, + sexp_cons(sexp_cdadr(x), sexp_cddr(x))), + context); + else + value = analyze(sexp_caddr(x), context); + analyze_check_exception(value); + ref = analyze_var_ref(name, context); + analyze_check_exception(ref); + return sexp_make_set(ref, value); +} + +static sexp analyze_bind_syntax (sexp ls, sexp eval_ctx, sexp bind_ctx) { + sexp proc; + for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) { + proc = eval_in_context(sexp_cadar(ls), eval_ctx); + analyze_check_exception(proc); + if (sexp_procedurep(proc)) + sexp_push(sexp_env_bindings(sexp_context_env(bind_ctx)), + sexp_cons(sexp_caar(ls), + sexp_make_macro(proc, sexp_context_env(eval_ctx)))); + } + return SEXP_VOID; +} + +static sexp analyze_define_syntax (sexp x, sexp context) { + return analyze_bind_syntax(sexp_list1(sexp_cdr(x)), context, context); +} + +static sexp analyze_let_syntax (sexp x, sexp context) { + sexp env, ctx, tmp; + env = sexp_alloc_type(env, SEXP_ENV); + sexp_env_parent(env) = sexp_env_parent(sexp_context_env(context)); + sexp_env_bindings(env) = sexp_env_bindings(sexp_context_env(context)); + ctx = sexp_child_context(context, sexp_context_lambda(context)); + sexp_context_env(ctx) = env; + tmp = analyze_bind_syntax(sexp_cadr(x), context, ctx); + analyze_check_exception(tmp); + return analyze_seq(sexp_cddr(x), ctx); +} + +static sexp analyze_letrec_syntax (sexp x, sexp context) { + sexp tmp = analyze_bind_syntax(sexp_cadr(x), context, context); + analyze_check_exception(tmp); + return analyze_seq(sexp_cddr(x), context); +} + +static sexp analyze (sexp x, sexp context) { + sexp op, cell, res; + loop: + if (sexp_pairp(x)) { + if (sexp_listp(x) == SEXP_FALSE) { + res = sexp_compile_error("dotted list in source", sexp_list1(x)); + } else if (sexp_idp(sexp_car(x))) { + cell = env_cell(sexp_context_env(context), sexp_car(x)); + if (! cell && sexp_synclop(sexp_car(x))) + cell = env_cell(sexp_synclo_env(sexp_car(x)), + sexp_synclo_expr(sexp_car(x))); + if (! cell) return analyze_app(x, context); + op = sexp_cdr(cell); + if (sexp_corep(op)) { + switch (sexp_core_code(op)) { + case CORE_DEFINE: + res = analyze_define(x, context); break; + case CORE_SET: + res = analyze_set(x, context); break; + case CORE_LAMBDA: + res = analyze_lambda(x, context); break; + case CORE_IF: + res = analyze_if(x, context); break; + case CORE_BEGIN: + res = analyze_seq(sexp_cdr(x), context); break; + case CORE_QUOTE: + res = sexp_make_lit(sexp_strip_syntactic_closures(sexp_cadr(x))); + break; + case CORE_DEFINE_SYNTAX: + res = analyze_define_syntax(x, context); break; + case CORE_LET_SYNTAX: + res = analyze_let_syntax(x, context); break; + case CORE_LETREC_SYNTAX: + res = analyze_letrec_syntax(x, context); break; + default: + res = sexp_compile_error("unknown core form", sexp_list1(op)); break; + } + } else if (sexp_macrop(op)) { + /* if (in_repl_p) sexp_debug("expand: ", x, context); */ + x = apply(sexp_macro_proc(op), + sexp_list3(x, sexp_context_env(context), sexp_macro_env(op)), + sexp_child_context(context, sexp_context_lambda(context))); + /* if (in_repl_p) sexp_debug(" => ", x, context); */ + goto loop; + } else if (sexp_opcodep(op)) { + res = sexp_length(sexp_cdr(x)); + if (sexp_unbox_integer(res) < sexp_opcode_num_args(op)) { + res = sexp_compile_error("not enough args for opcode", sexp_list1(x)); + } else if ((sexp_unbox_integer(res) > sexp_opcode_num_args(op)) + && (! sexp_opcode_variadic_p(op))) { + res = sexp_compile_error("too many args for opcode", sexp_list1(x)); + } else { + res = analyze_app(sexp_cdr(x), context); + analyze_check_exception(res); + sexp_push(res, op); + } + } else { + res = analyze_app(x, context); + } + } else { + res = analyze_app(x, context); + } + } else if (sexp_idp(x)) { + res = analyze_var_ref(x, context); + } else if (sexp_synclop(x)) { + context = sexp_child_context(context, sexp_context_lambda(context)); + sexp_context_env(context) = sexp_synclo_env(x); + sexp_context_fv(context) = sexp_append(sexp_synclo_free_vars(x), + sexp_context_fv(context)); + x = sexp_synclo_expr(x); + goto loop; + } else { + res = x; + } + return res; +} + +static sexp_sint_t sexp_context_make_label (sexp context) { + sexp_sint_t label = sexp_context_pos(context); + sexp_context_pos(context) += sizeof(sexp_uint_t); + return label; +} + +static void sexp_context_patch_label (sexp context, sexp_sint_t label) { + sexp bc = sexp_context_bc(context); + unsigned char *data = sexp_bytecode_data(bc)+label; + *((sexp_sint_t*)data) = sexp_context_pos(context)-label; +} + +static sexp finalize_bytecode (sexp context) { + emit(OP_RET, context); + shrink_bcode(context, sexp_context_pos(context)); + return sexp_context_bc(context); +} + +static void generate_lit (sexp value, sexp context) { + emit_push(value, context); +} + +static void generate_seq (sexp app, sexp context) { + sexp head=app, tail=sexp_cdr(app); + sexp_uint_t tailp = sexp_context_tailp(context); + sexp_context_tailp(context) = 0; + for ( ; sexp_pairp(tail); head=tail, tail=sexp_cdr(tail)) + if (sexp_pointerp(sexp_car(head)) && (! sexp_litp(sexp_car(head)))) { + generate(sexp_car(head), context); + emit(OP_DROP, context); + sexp_context_depth(context)--; + } + sexp_context_tailp(context) = tailp; + generate(sexp_car(head), context); +} + +static void generate_cnd (sexp cnd, sexp context) { + sexp_sint_t label1, label2, tailp=sexp_context_tailp(context); + sexp_context_tailp(context) = 0; + generate(sexp_cnd_test(cnd), context); + sexp_context_tailp(context) = tailp; + emit(OP_JUMP_UNLESS, context); + sexp_context_depth(context)--; + label1 = sexp_context_make_label(context); + generate(sexp_cnd_pass(cnd), context); + emit(OP_JUMP, context); + sexp_context_depth(context)--; + label2 = sexp_context_make_label(context); + sexp_context_patch_label(context, label1); + generate(sexp_cnd_fail(cnd), context); + sexp_context_patch_label(context, label2); +} + +static void generate_non_global_ref (sexp name, sexp cell, sexp lambda, + sexp fv, sexp context, int unboxp) { + sexp_uint_t i; + sexp loc = sexp_cdr(cell); + if (loc == lambda && sexp_lambdap(lambda)) { + /* local ref */ + emit(OP_LOCAL_REF, context); + emit_word(sexp_param_index(lambda, name), context); + } else { + /* closure ref */ + for (i=0; sexp_pairp(fv); fv=sexp_cdr(fv), i++) + if ((name == sexp_ref_name(sexp_car(fv))) + && (loc == sexp_ref_loc(sexp_car(fv)))) + break; + emit(OP_CLOSURE_REF, context); + emit_word(i, context); + } + if (unboxp && (sexp_memq(name, sexp_lambda_sv(loc)) != SEXP_FALSE)) + emit(OP_CDR, context); + sexp_context_depth(context)++; +} + +static void generate_ref (sexp ref, sexp context, int unboxp) { + sexp lam; + if (! sexp_lambdap(sexp_ref_loc(ref))) { + /* global ref */ + if (unboxp) { + emit((sexp_cdr(sexp_ref_cell(ref)) == SEXP_UNDEF) + ? OP_GLOBAL_REF : OP_GLOBAL_KNOWN_REF, + context); + emit_word((sexp_uint_t)sexp_ref_cell(ref), context); + } else + emit_push(sexp_ref_cell(ref), context); + } else { + lam = sexp_context_lambda(context); + generate_non_global_ref(sexp_ref_name(ref), sexp_ref_cell(ref), lam, + sexp_lambda_fv(lam), context, unboxp); + } +} + +static void generate_set (sexp set, sexp context) { + sexp ref = sexp_set_var(set), lambda; + /* compile the value */ + sexp_context_tailp(context) = 0; + if (sexp_lambdap(sexp_set_value(set))) + sexp_lambda_name(sexp_set_value(set)) = sexp_ref_name(ref); + generate(sexp_set_value(set), context); + if (! sexp_lambdap(sexp_ref_loc(ref))) { + /* global vars are set directly */ + emit_push(sexp_ref_cell(ref), context); + emit(OP_SET_CDR, context); + } else { + lambda = sexp_ref_loc(ref); + if (sexp_memq(sexp_ref_name(ref), sexp_lambda_sv(lambda)) != SEXP_FALSE) { + /* stack or closure mutable vars are boxed */ + generate_ref(ref, context, 0); + emit(OP_SET_CDR, context); + } else { + /* internally defined variable */ + emit(OP_LOCAL_SET, context); + emit_word(sexp_param_index(lambda, sexp_ref_name(ref)), context); + } + } + sexp_context_depth(context)--; +} + +static void generate_opcode_app (sexp app, sexp context) { + sexp ls, op = sexp_car(app); + sexp_sint_t i, num_args = sexp_unbox_integer(sexp_length(sexp_cdr(app))); + sexp_context_tailp(context) = 0; + + /* maybe push the default for an optional argument */ + if ((num_args == sexp_opcode_num_args(op)) + && sexp_opcode_variadic_p(op) + && sexp_opcode_default(op) + && (sexp_opcode_class(op) != OPC_PARAMETER)) { + emit_push(sexp_opcode_default(op), context); + if (sexp_opcode_opt_param_p(op)) + emit(OP_CDR, context); + sexp_context_depth(context)++; + num_args++; + } + + /* push the arguments onto the stack */ + ls = ((sexp_opcode_inverse(op) + && (sexp_opcode_class(op) != OPC_ARITHMETIC_INV)) + ? sexp_cdr(app) : sexp_reverse(sexp_cdr(app))); + for ( ; sexp_pairp(ls); ls = sexp_cdr(ls)) + generate(sexp_car(ls), context); + + /* emit the actual operator call */ + switch (sexp_opcode_class(op)) { + case OPC_ARITHMETIC: + if (num_args > 1) + emit(sexp_opcode_code(op), context); + break; + case OPC_ARITHMETIC_INV: + emit((num_args == 1) ? sexp_opcode_inverse(op) + : sexp_opcode_code(op), context); + break; + case OPC_ARITHMETIC_CMP: + if (num_args > 2) { + emit(OP_STACK_REF, context); + emit_word(2, context); + emit(OP_STACK_REF, context); + emit_word(2, context); + emit(sexp_opcode_code(op), context); + emit(OP_AND, context); + for (i=num_args-2; i>0; i--) { + emit(OP_STACK_REF, context); + emit_word(3, context); + emit(OP_STACK_REF, context); + emit_word(3, context); + emit(sexp_opcode_code(op), context); + emit(OP_AND, context); + emit(OP_AND, context); + } + } else + emit(sexp_opcode_code(op), context); + break; + case OPC_FOREIGN: + case OPC_TYPE_PREDICATE: + /* push the funtion pointer for foreign calls */ + emit(sexp_opcode_code(op), context); + if (sexp_opcode_data(op)) + emit_word((sexp_uint_t)sexp_opcode_data(op), context); + break; + case OPC_PARAMETER: + emit_push(sexp_opcode_default(op), context); + emit((num_args == 0 ? OP_CDR : OP_SET_CDR), context); + break; + default: + emit(sexp_opcode_code(op), context); + } + + /* emit optional folding of operator */ + if ((num_args > 2) + && (sexp_opcode_class(op) == OPC_ARITHMETIC + || sexp_opcode_class(op) == OPC_ARITHMETIC_INV)) + for (i=num_args-2; i>0; i--) + emit(sexp_opcode_code(op), context); + + sexp_context_depth(context) -= (num_args-1); +} + +static void generate_general_app (sexp app, sexp context) { + sexp ls; + sexp_uint_t len = sexp_unbox_integer(sexp_length(sexp_cdr(app))), + tailp = sexp_context_tailp(context); + + /* push the arguments onto the stack */ + sexp_context_tailp(context) = 0; + for (ls = sexp_reverse(sexp_cdr(app)); sexp_pairp(ls); ls = sexp_cdr(ls)) + generate(sexp_car(ls), context); + + /* push the operator onto the stack */ + generate(sexp_car(app), context); + + /* maybe overwrite the current frame */ + emit((tailp ? OP_TAIL_CALL : OP_CALL), context); + emit_word((sexp_uint_t)sexp_make_integer(len), context); + + sexp_context_depth(context) -= len; +} + +static void generate_app (sexp app, sexp context) { + if (sexp_opcodep(sexp_car(app))) + generate_opcode_app(app, context); + else + generate_general_app(app, context); +} + +static void generate_lambda (sexp lambda, sexp context) { + sexp fv, ls, ctx, flags, bc, len, ref, vec, prev_lambda, prev_fv; + sexp_uint_t k; + prev_lambda = sexp_context_lambda(context); + prev_fv = sexp_lambdap(prev_lambda) ? sexp_lambda_fv(prev_lambda) : SEXP_NULL; + fv = sexp_lambda_fv(lambda); + ctx = sexp_make_context(sexp_context_stack(context), + sexp_context_env(context)); + sexp_context_lambda(ctx) = lambda; + /* allocate space for local vars */ + for (ls=sexp_lambda_locals(lambda); sexp_pairp(ls); ls=sexp_cdr(ls)) + emit_push(SEXP_VOID, ctx); + /* box mutable vars */ + for (ls=sexp_lambda_sv(lambda); sexp_pairp(ls); ls=sexp_cdr(ls)) { + k = sexp_param_index(lambda, sexp_car(ls)); + if (k >= 0) { + emit(OP_LOCAL_REF, ctx); + emit_word(k, ctx); + emit_push(sexp_car(ls), ctx); + emit(OP_CONS, ctx); + emit(OP_LOCAL_SET, ctx); + emit_word(k, ctx); + emit(OP_DROP, ctx); + } + } + sexp_context_tailp(ctx) = 1; + generate(sexp_lambda_body(lambda), ctx); + flags = sexp_make_integer((sexp_listp(sexp_lambda_params(lambda))==SEXP_FALSE) + ? 1 : 0); + len = sexp_length(sexp_lambda_params(lambda)); + bc = finalize_bytecode(ctx); + sexp_bytecode_name(bc) = sexp_lambda_name(lambda); + if (sexp_nullp(fv)) { + /* shortcut, no free vars */ + vec = sexp_make_vector(sexp_make_integer(0), SEXP_VOID); + generate_lit(sexp_make_procedure(flags, len, bc, vec), context); + } else { + /* push the closed vars */ + emit_push(SEXP_VOID, context); + emit_push(sexp_length(fv), context); + emit(OP_MAKE_VECTOR, context); + sexp_context_depth(context)--; + for (k=0; sexp_pairp(fv); fv=sexp_cdr(fv), k++) { + ref = sexp_car(fv); + generate_non_global_ref(sexp_ref_name(ref), sexp_ref_cell(ref), + prev_lambda, prev_fv, context, 0); + emit_push(sexp_make_integer(k), context); + emit(OP_STACK_REF, context); + emit_word(3, context); + emit(OP_VECTOR_SET, context); + emit(OP_DROP, context); + sexp_context_depth(context)--; + } + /* push the additional procedure info and make the closure */ + emit_push(bc, context); + emit_push(len, context); + emit_push(flags, context); + emit(OP_MAKE_PROCEDURE, context); + } +} + +static void generate (sexp x, sexp context) { + if (sexp_pointerp(x)) { + switch (sexp_pointer_tag(x)) { + case SEXP_PAIR: + generate_app(x, context); + break; + case SEXP_LAMBDA: + generate_lambda(x, context); + break; + case SEXP_CND: + generate_cnd(x, context); + break; + case SEXP_REF: + generate_ref(x, context, 1); + break; + case SEXP_SET: + generate_set(x, context); + break; + case SEXP_SEQ: + generate_seq(sexp_seq_ls(x), context); + break; + case SEXP_LIT: + generate_lit(sexp_lit_value(x), context); + break; + default: + generate_lit(x, context); + } + } else { + generate_lit(x, context); + } +} + +static sexp insert_free_var (sexp x, sexp fv) { + sexp name=sexp_ref_name(x), loc=sexp_ref_loc(x), ls; + for (ls=fv; sexp_pairp(ls); ls=sexp_cdr(ls)) + if ((name == sexp_ref_name(sexp_car(ls))) + && (loc == sexp_ref_loc(sexp_car(ls)))) + return fv; + return sexp_cons(x, fv); +} + +static sexp union_free_vars (sexp fv1, sexp fv2) { + if (sexp_nullp(fv2)) + return fv1; + for ( ; sexp_pairp(fv1); fv1=sexp_cdr(fv1)) + fv2 = insert_free_var(sexp_car(fv1), fv2); + return fv2; +} + +static sexp diff_free_vars (sexp lambda, sexp fv, sexp params) { + sexp res = SEXP_NULL; + for ( ; sexp_pairp(fv); fv=sexp_cdr(fv)) + if ((sexp_ref_loc(sexp_car(fv)) != lambda) + || (sexp_memq(sexp_ref_name(sexp_car(fv)), params) == SEXP_FALSE)) + sexp_push(res, sexp_car(fv)); + return res; +} + +static sexp free_vars (sexp x, sexp fv) { + sexp fv1, fv2; + if (sexp_lambdap(x)) { + fv1 = free_vars(sexp_lambda_body(x), SEXP_NULL); + fv2 = diff_free_vars(x, + fv1, + sexp_append(sexp_lambda_locals(x), + sexp_flatten_dot(sexp_lambda_params(x)))); + sexp_lambda_fv(x) = fv2; + fv = union_free_vars(fv2, fv); + } else if (sexp_pairp(x)) { + for ( ; sexp_pairp(x); x=sexp_cdr(x)) + fv = free_vars(sexp_car(x), fv); + } else if (sexp_cndp(x)) { + fv = free_vars(sexp_cnd_test(x), fv); + fv = free_vars(sexp_cnd_pass(x), fv); + fv = free_vars(sexp_cnd_fail(x), fv); + } else if (sexp_seqp(x)) { + for (x=sexp_seq_ls(x); sexp_pairp(x); x=sexp_cdr(x)) + fv = free_vars(sexp_car(x), fv); + } else if (sexp_setp(x)) { + fv = free_vars(sexp_set_value(x), fv); + fv = free_vars(sexp_set_var(x), fv); + } else if (sexp_refp(x) && sexp_lambdap(sexp_ref_loc(x))) { + fv = insert_free_var(x, fv); + } else if (sexp_synclop(x)) { + fv = free_vars(sexp_synclo_expr(x), fv); + } + return fv; +} + +static sexp make_param_list(sexp_uint_t i) { + sexp res = SEXP_NULL; + char sym[2]="a"; + for (sym[0]+=i; i>0; i--) { + sym[0] = sym[0]-1; + res = sexp_cons(sexp_intern(sym), res); + } + return res; +} + +static sexp make_opcode_procedure (sexp op, sexp_uint_t i, sexp env, + sexp *stack, sexp_sint_t top) { + sexp context, lambda, params, refs, ls, bc, res; + if (i == sexp_opcode_num_args(op) && sexp_opcode_proc(op)) + return sexp_opcode_proc(op); + params = make_param_list(i); + lambda = sexp_make_lambda(params); + env = extend_env(env, params, lambda); + context = sexp_make_context(stack, env); + sexp_context_lambda(context) = lambda; + sexp_context_top(context) = top; + for (ls=params, refs=SEXP_NULL; sexp_pairp(ls); ls=sexp_cdr(ls)) + sexp_push(refs, sexp_make_ref(sexp_car(ls), env_cell(env, sexp_car(ls)))); + generate_opcode_app(sexp_cons(op, sexp_reverse(refs)), context); + bc = finalize_bytecode(context); + sexp_bytecode_name(bc) = sexp_c_string(sexp_opcode_name(op)); + res = sexp_make_procedure(sexp_make_integer(0), + sexp_make_integer(i), + bc, + SEXP_VOID); + if (i == sexp_opcode_num_args(op)) + sexp_opcode_proc(op) = res; + return res; +} + +/*********************** the virtual machine **************************/ + +static sexp sexp_save_stack(sexp *stack, sexp_uint_t to) { + sexp res, *data; + sexp_uint_t i; + res = sexp_make_vector(sexp_make_integer(to), SEXP_VOID); + data = sexp_vector_data(res); + for (i=0; i= INIT_STACK_SIZE) + sexp_raise("out of stack space", SEXP_NULL); +#endif + i = sexp_unbox_integer(_WORD0); + tmp1 = _ARG1; + make_call: + if (sexp_opcodep(tmp1)) { + /* compile non-inlined opcode applications on the fly */ + tmp1 = make_opcode_procedure(tmp1, i, env, stack, top); + if (sexp_exceptionp(tmp1)) { + _ARG1 = tmp1; + goto call_error_handler; + } + } + if (! sexp_procedurep(tmp1)) + sexp_raise("non procedure application", sexp_list1(tmp1)); + j = i - sexp_unbox_integer(sexp_procedure_num_args(tmp1)); + if (j < 0) + sexp_raise("not enough args", sexp_list2(tmp1, sexp_make_integer(i))); + if (j > 0) { + if (sexp_procedure_variadic_p(tmp1)) { + stack[top-i-1] = sexp_cons(stack[top-i-1], SEXP_NULL); + for (k=top-i; k=top-i; k--) + stack[k] = stack[k-1]; + stack[top-i-1] = SEXP_NULL; + top++; + i++; + } + _ARG1 = sexp_make_integer(i); + stack[top] = sexp_make_integer(ip+sizeof(sexp)); + stack[top+1] = self; + stack[top+2] = sexp_make_integer(fp); + top += 3; + self = tmp1; + bc = sexp_procedure_code(self); + ip = sexp_bytecode_data(bc); + cp = sexp_procedure_vars(self); + fp = top-4; + break; + case OP_FCALL0: + _PUSH(((sexp_proc0)_UWORD0)()); + ip += sizeof(sexp); + sexp_check_exception(); + break; + case OP_FCALL1: + _ARG1 = ((sexp_proc1)_UWORD0)(_ARG1); + ip += sizeof(sexp); + sexp_check_exception(); + break; + case OP_FCALL2: + _ARG2 = ((sexp_proc2)_UWORD0)(_ARG1, _ARG2); + top--; + ip += sizeof(sexp); + sexp_check_exception(); + break; + case OP_FCALL3: + _ARG3 =((sexp_proc3)_UWORD0)(_ARG1, _ARG2, _ARG3); + top -= 2; + ip += sizeof(sexp); + sexp_check_exception(); + break; + case OP_FCALL4: + _ARG4 =((sexp_proc4)_UWORD0)(_ARG1, _ARG2, _ARG3, _ARG4); + top -= 3; + ip += sizeof(sexp); + sexp_check_exception(); + break; + case OP_FCALL5: + _ARG5 =((sexp_proc5)_UWORD0)(_ARG1, _ARG2, _ARG3, _ARG4, _ARG5); + top -= 4; + ip += sizeof(sexp); + sexp_check_exception(); + break; + case OP_FCALL6: + _ARG6 =((sexp_proc6)_UWORD0)(_ARG1, _ARG2, _ARG3, _ARG4, _ARG5, _ARG6); + top -= 5; + ip += sizeof(sexp); + sexp_check_exception(); + break; + case OP_EVAL: + sexp_context_top(context) = top; + _ARG1 = eval_in_context(_ARG1, context); + sexp_check_exception(); + break; + case OP_JUMP_UNLESS: + if (stack[--top] == SEXP_FALSE) + ip += _SWORD0; + else + ip += sizeof(sexp_sint_t); + break; + case OP_JUMP: + ip += _SWORD0; + break; + case OP_PUSH: + _PUSH(_WORD0); + ip += sizeof(sexp); + break; + case OP_DROP: + top--; + break; + case OP_GLOBAL_REF: + if (sexp_cdr(_WORD0) == SEXP_UNDEF) + sexp_raise("undefined variable", sexp_list1(sexp_car(_WORD0))); + /* ... FALLTHROUGH ... */ + case OP_GLOBAL_KNOWN_REF: + _PUSH(sexp_cdr(_WORD0)); + ip += sizeof(sexp); + break; + case OP_STACK_REF: /* `pick' in forth */ + stack[top] = stack[top - _SWORD0]; + ip += sizeof(sexp); + top++; + break; + case OP_LOCAL_REF: + stack[top] = stack[fp - 1 - _SWORD0]; + ip += sizeof(sexp); + top++; + break; + case OP_LOCAL_SET: + stack[fp - 1 - _SWORD0] = _ARG1; + _ARG1 = SEXP_VOID; + ip += sizeof(sexp); + break; + case OP_CLOSURE_REF: + _PUSH(sexp_vector_ref(cp, sexp_make_integer(_WORD0))); + ip += sizeof(sexp); + break; + case OP_VECTOR_REF: + if (! sexp_vectorp(_ARG1)) + sexp_raise("vector-ref: not a vector", sexp_list1(_ARG1)); + _ARG2 = sexp_vector_ref(_ARG1, _ARG2); + top--; + break; + case OP_VECTOR_SET: + if (! sexp_vectorp(_ARG1)) + sexp_raise("vector-set!: not a vector", sexp_list1(_ARG1)); + sexp_vector_set(_ARG1, _ARG2, _ARG3); + _ARG3 = SEXP_VOID; + top-=2; + break; + case OP_VECTOR_LENGTH: + _ARG1 = sexp_make_integer(sexp_vector_length(_ARG1)); + break; + case OP_STRING_REF: + _ARG2 = sexp_string_ref(_ARG1, _ARG2); + top--; + break; + case OP_STRING_SET: + sexp_string_set(_ARG1, _ARG2, _ARG3); + _ARG3 = SEXP_VOID; + top-=2; + break; + case OP_STRING_LENGTH: + _ARG1 = sexp_make_integer(sexp_string_length(_ARG1)); + break; + case OP_MAKE_PROCEDURE: + _ARG4 = sexp_make_procedure(_ARG1, _ARG2, _ARG3, _ARG4); + top-=3; + break; + case OP_MAKE_VECTOR: + _ARG2 = sexp_make_vector(_ARG1, _ARG2); + top--; + break; + case OP_AND: + _ARG2 = sexp_make_boolean((_ARG1 != SEXP_FALSE) && (_ARG2 != SEXP_FALSE)); + top--; + break; + case OP_EOFP: + _ARG1 = sexp_make_boolean(_ARG1 == SEXP_EOF); break; + case OP_NULLP: + _ARG1 = sexp_make_boolean(sexp_nullp(_ARG1)); break; + case OP_INTEGERP: + _ARG1 = sexp_make_boolean(sexp_integerp(_ARG1)); break; + case OP_SYMBOLP: + _ARG1 = sexp_make_boolean(sexp_symbolp(_ARG1)); break; + case OP_CHARP: + _ARG1 = sexp_make_boolean(sexp_charp(_ARG1)); break; + case OP_TYPEP: + _ARG1 = sexp_make_boolean(sexp_pointerp(_ARG1) + && (sexp_pointer_tag(_ARG1) + == _UWORD0)); + ip += sizeof(sexp); + break; + case OP_CAR: + if (! sexp_pairp(_ARG1)) sexp_raise("car: not a pair", sexp_list1(_ARG1)); + _ARG1 = sexp_car(_ARG1); break; + case OP_CDR: + if (! sexp_pairp(_ARG1)) sexp_raise("cdr: not a pair", sexp_list1(_ARG1)); + _ARG1 = sexp_cdr(_ARG1); break; + case OP_SET_CAR: + if (! sexp_pairp(_ARG1)) + sexp_raise("set-car!: not a pair", sexp_list1(_ARG1)); + sexp_car(_ARG1) = _ARG2; + _ARG2 = SEXP_VOID; + top--; + break; + case OP_SET_CDR: + if (! sexp_pairp(_ARG1)) + sexp_raise("set-cdr!: not a pair", sexp_list1(_ARG1)); + sexp_cdr(_ARG1) = _ARG2; + _ARG2 = SEXP_VOID; + top--; + break; + case OP_CONS: + _ARG2 = sexp_cons(_ARG1, _ARG2); + top--; + break; + case OP_ADD: + if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) + _ARG2 = sexp_fx_add(_ARG1, _ARG2); +#if USE_FLONUMS + else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_fp_add(_ARG1, _ARG2); + else if (sexp_flonump(_ARG1) && sexp_integerp(_ARG2)) + _ARG2 = sexp_fp_add(_ARG1, sexp_integer_to_flonum(_ARG2)); + else if (sexp_integerp(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_fp_add(sexp_integer_to_flonum(_ARG1), _ARG2); +#endif + else sexp_raise("+: not a number", sexp_list2(_ARG1, _ARG2)); + top--; + break; + case OP_SUB: + if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) + _ARG2 = sexp_fx_sub(_ARG1, _ARG2); +#if USE_FLONUMS + else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_fp_sub(_ARG1, _ARG2); + else if (sexp_flonump(_ARG1) && sexp_integerp(_ARG2)) + _ARG2 = sexp_fp_sub(_ARG1, sexp_integer_to_flonum(_ARG2)); + else if (sexp_integerp(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_fp_sub(sexp_integer_to_flonum(_ARG1), _ARG2); +#endif + else sexp_raise("-: not a number", sexp_list2(_ARG1, _ARG2)); + top--; + break; + case OP_MUL: + if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) + _ARG2 = sexp_fx_mul(_ARG1, _ARG2); +#if USE_FLONUMS + else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_fp_mul(_ARG1, _ARG2); + else if (sexp_flonump(_ARG1) && sexp_integerp(_ARG2)) + _ARG2 = sexp_fp_mul(_ARG1, sexp_integer_to_flonum(_ARG2)); + else if (sexp_integerp(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_fp_mul(sexp_integer_to_flonum(_ARG1), _ARG2); +#endif + else sexp_raise("*: not a number", sexp_list2(_ARG1, _ARG2)); + top--; + break; + case OP_DIV: + if (_ARG2 == sexp_make_integer(0)) + sexp_raise("divide by zero", SEXP_NULL); + if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) + _ARG2 = sexp_fp_div(sexp_integer_to_flonum(_ARG1), + sexp_integer_to_flonum(_ARG2)); +#if USE_FLONUMS + else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_fp_div(_ARG1, _ARG2); + else if (sexp_flonump(_ARG1) && sexp_integerp(_ARG2)) + _ARG2 = sexp_fp_div(_ARG1, sexp_integer_to_flonum(_ARG2)); + else if (sexp_integerp(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_fp_div(sexp_integer_to_flonum(_ARG1), _ARG2); +#endif + else sexp_raise("/: not a number", sexp_list2(_ARG1, _ARG2)); + top--; + break; + case OP_QUOTIENT: + if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) { + if (_ARG2 == sexp_make_integer(0)) + sexp_raise("divide by zero", SEXP_NULL); + _ARG2 = sexp_fx_div(_ARG1, _ARG2); + top--; + } + else sexp_raise("quotient: not an integer", sexp_list2(_ARG1, _ARG2)); + break; + case OP_REMAINDER: + if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) { + if (_ARG2 == sexp_make_integer(0)) + sexp_raise("divide by zero", SEXP_NULL); + tmp1 = sexp_fx_rem(_ARG1, _ARG2); + top--; + _ARG1 = tmp1; + } + else sexp_raise("remainder: not an integer", sexp_list2(_ARG1, _ARG2)); + break; + case OP_NEGATIVE: + if (sexp_integerp(_ARG1)) + _ARG1 = sexp_make_integer(-sexp_unbox_integer(_ARG1)); +#if USE_FLONUMS + else if (sexp_flonump(_ARG1)) + _ARG1 = sexp_make_flonum(-sexp_flonum_value(_ARG1)); +#endif + else sexp_raise("-: not a number", sexp_list1(_ARG1)); + break; + case OP_INVERSE: + if (sexp_integerp(_ARG1)) + _ARG1 = sexp_make_flonum(1/(double)sexp_unbox_integer(_ARG1)); +#if USE_FLONUMS + else if (sexp_flonump(_ARG1)) + _ARG1 = sexp_make_flonum(1/sexp_flonum_value(_ARG1)); +#endif + else sexp_raise("/: not a number", sexp_list1(_ARG1)); + break; + case OP_LT: + if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) + i = (sexp_sint_t)_ARG1 < (sexp_sint_t)_ARG2; +#if USE_FLONUMS + else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) + i = sexp_flonum_value(_ARG1) < sexp_flonum_value(_ARG2); + else if (sexp_flonump(_ARG1) && sexp_integerp(_ARG2)) + i = sexp_flonum_value(_ARG1) < (double)sexp_unbox_integer(_ARG2); + else if (sexp_integerp(_ARG1) && sexp_flonump(_ARG2)) + i = (double)sexp_unbox_integer(_ARG1) < sexp_flonum_value(_ARG2); +#endif + else sexp_raise("<: not a number", sexp_list2(_ARG1, _ARG2)); + _ARG2 = sexp_make_boolean(i); + top--; + break; + case OP_LE: + if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) + i = (sexp_sint_t)_ARG1 <= (sexp_sint_t)_ARG2; +#if USE_FLONUMS + else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) + i = sexp_flonum_value(_ARG1) <= sexp_flonum_value(_ARG2); + else if (sexp_flonump(_ARG1) && sexp_integerp(_ARG2)) + i = sexp_flonum_value(_ARG1) <= (double)sexp_unbox_integer(_ARG2); + else if (sexp_integerp(_ARG1) && sexp_flonump(_ARG2)) + i = (double)sexp_unbox_integer(_ARG1) <= sexp_flonum_value(_ARG2); +#endif + else sexp_raise("<=: not a number", sexp_list2(_ARG1, _ARG2)); + _ARG2 = sexp_make_boolean(i); + top--; + break; + case OP_EQN: + if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) + i = _ARG1 == _ARG2; +#if USE_FLONUMS + else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) + i = sexp_flonum_value(_ARG1) == sexp_flonum_value(_ARG2); + else if (sexp_flonump(_ARG1) && sexp_integerp(_ARG2)) + i = sexp_flonum_value(_ARG1) == (double)sexp_unbox_integer(_ARG2); + else if (sexp_integerp(_ARG1) && sexp_flonump(_ARG2)) + i = (double)sexp_unbox_integer(_ARG1) == sexp_flonum_value(_ARG2); +#endif + else sexp_raise("=: not a number", sexp_list2(_ARG1, _ARG2)); + _ARG2 = sexp_make_boolean(i); + top--; + break; + case OP_EQ: + _ARG2 = sexp_make_boolean(_ARG1 == _ARG2); + top--; + break; + case OP_FIX2FLO: + if (sexp_integerp(_ARG1)) + _ARG1 = sexp_integer_to_flonum(_ARG1); + else +#if USE_FLONUMS + if (! sexp_flonump(_ARG1)) +#endif + sexp_raise("exact->inexact: not a number", sexp_list1(_ARG1)); + break; + case OP_FLO2FIX: +#if USE_FLONUMS + if (sexp_flonump(_ARG1)) + _ARG1 = sexp_make_integer((sexp_sint_t)sexp_flonum_value(_ARG1)); + else +#endif + if (! sexp_integerp(_ARG1)) + sexp_raise("inexact->exact: not a number", sexp_list1(_ARG1)); + break; + case OP_CHAR2INT: + _ARG1 = sexp_make_integer(sexp_unbox_character(_ARG1)); + break; + case OP_INT2CHAR: + _ARG1 = sexp_make_character(sexp_unbox_integer(_ARG1)); + break; + case OP_CHAR_UPCASE: + _ARG1 = sexp_make_character(toupper(sexp_unbox_character(_ARG1))); + break; + case OP_CHAR_DOWNCASE: + _ARG1 = sexp_make_character(tolower(sexp_unbox_character(_ARG1))); + break; + case OP_DISPLAY: + if (sexp_stringp(_ARG1)) { + sexp_write_string(sexp_string_data(_ARG1), _ARG2); + _ARG2 = SEXP_VOID; + top--; + break; + } else if (sexp_charp(_ARG1)) { + sexp_write_char(sexp_unbox_character(_ARG1), _ARG2); + _ARG2 = SEXP_VOID; + top--; + break; + } + /* ... FALLTHROUGH ... */ + case OP_WRITE: + sexp_write(_ARG1, _ARG2); + _ARG2 = SEXP_VOID; + top--; + break; + case OP_WRITE_CHAR: + sexp_write_char(sexp_unbox_character(_ARG1), _ARG2); + _ARG2 = SEXP_VOID; + top--; + break; + case OP_NEWLINE: + sexp_write_char('\n', _ARG1); + _ARG1 = SEXP_VOID; + break; + case OP_FLUSH_OUTPUT: + sexp_flush(_ARG1); + _ARG1 = SEXP_VOID; + break; + case OP_READ: + _ARG1 = sexp_read(_ARG1); + sexp_check_exception(); + break; + case OP_READ_CHAR: + i = sexp_read_char(_ARG1); + _ARG1 = (i == EOF) ? SEXP_EOF : sexp_make_character(i); + break; + case OP_PEEK_CHAR: + i = sexp_read_char(_ARG1); + sexp_push_char(i, _ARG1); + _ARG1 = (i == EOF) ? SEXP_EOF : sexp_make_character(i); + break; + case OP_RET: + i = sexp_unbox_integer(stack[fp]); + stack[fp-i] = _ARG1; + top = fp-i+1; + ip = (unsigned char*) sexp_unbox_integer(stack[fp+1]); + self = stack[fp+2]; + bc = sexp_procedure_code(self); + cp = sexp_procedure_vars(self); + fp = sexp_unbox_integer(stack[fp+3]); + break; + case OP_DONE: + goto end_loop; + default: + sexp_raise("unknown opcode", sexp_list1(sexp_make_integer(*(ip-1)))); + } + goto loop; + + end_loop: + return _ARG1; +} + +/************************ library procedures **************************/ + +static sexp sexp_exception_type_func (sexp exn) { + if (sexp_exceptionp(exn)) + return sexp_exception_kind(exn); + else + return sexp_type_exception("not an exception", exn); +} + +static sexp sexp_open_input_file (sexp path) { + FILE *in; + if (! sexp_stringp(path)) return sexp_type_exception("not a string", path); + in = fopen(sexp_string_data(path), "r"); + if (! in) + return sexp_user_exception(SEXP_FALSE, "couldn't open input file", path); + return sexp_make_input_port(in, sexp_string_data(path)); +} + +static sexp sexp_open_output_file (sexp path) { + FILE *out; + if (! sexp_stringp(path)) return sexp_type_exception("not a string", path); + out = fopen(sexp_string_data(path), "w"); + if (! out) + return sexp_user_exception(SEXP_FALSE, "couldn't open output file", path); + return sexp_make_input_port(out, sexp_string_data(path)); +} + +static sexp sexp_close_port (sexp port) { + fclose(sexp_port_stream(port)); + return SEXP_VOID; +} + +static void sexp_warn_undefs (sexp from, sexp to, sexp out) { + sexp x; + for (x=from; sexp_pairp(x) && x!=to; x=sexp_cdr(x)) + if (sexp_cdar(x) == SEXP_UNDEF) { + sexp_write_string("WARNING: reference to undefined variable: ", out); + sexp_write(sexp_caar(x), out); + sexp_write_char('\n', out); + } +} + +sexp sexp_load (sexp source, sexp env) { + sexp x, res, in, tmp, out, context = sexp_make_context(NULL, env); + out = env_global_ref(env, the_cur_err_symbol, SEXP_FALSE); + tmp = sexp_env_bindings(env); + sexp_context_tailp(context) = 0; + in = sexp_open_input_file(source); + if (sexp_exceptionp(in)) { + sexp_print_exception(in, out); + return in; + } + while ((x=sexp_read(in)) != (sexp) SEXP_EOF) { + res = eval_in_context(x, context); + if (sexp_exceptionp(res)) + break; + } + if (x == SEXP_EOF) + res = SEXP_VOID; + sexp_close_port(in); +#ifdef USE_WARN_UNDEFS + if (sexp_oportp(out)) + sexp_warn_undefs(sexp_env_bindings(env), tmp, out); +#endif + return res; +} + +#if USE_MATH + +#define define_math_op(name, cname) \ + static sexp name (sexp z) { \ + double d; \ + if (sexp_flonump(z)) \ + d = sexp_flonum_value(z); \ + else if (sexp_integerp(z)) \ + d = (double)sexp_unbox_integer(z); \ + else \ + return sexp_type_exception("not a number", z); \ + return sexp_make_flonum(cname(d)); \ + } + +define_math_op(sexp_exp, exp) +define_math_op(sexp_log, log) +define_math_op(sexp_sin, sin) +define_math_op(sexp_cos, cos) +define_math_op(sexp_tan, tan) +define_math_op(sexp_asin, asin) +define_math_op(sexp_acos, acos) +define_math_op(sexp_atan, atan) +define_math_op(sexp_sqrt, sqrt) +define_math_op(sexp_round, round) +define_math_op(sexp_trunc, trunc) +define_math_op(sexp_floor, floor) +define_math_op(sexp_ceiling, ceil) + +#endif + +static sexp sexp_expt (sexp x, sexp e) { + double res, x1, e1; + if (sexp_integerp(x)) + x1 = (double)sexp_unbox_integer(x); +#if USE_FLONUMS + else if (sexp_flonump(x)) + x1 = sexp_flonum_value(x); +#endif + else + return sexp_type_exception("not a number", x); + if (sexp_integerp(e)) + e1 = (double)sexp_unbox_integer(e); +#if USE_FLONUMS + else if (sexp_flonump(e)) + e1 = sexp_flonum_value(e); +#endif + else + return sexp_type_exception("not a number", e); + res = pow(x1, e1); +#if USE_FLONUMS + if ((res > SEXP_MAX_INT) || sexp_flonump(x) || sexp_flonump(e)) + return sexp_make_flonum(res); +#endif + return sexp_make_integer((sexp_sint_t)round(res)); +} + +static sexp sexp_string_concatenate (sexp str_ls) { + sexp res, ls; + sexp_uint_t len=0; + char *p; + for (ls=str_ls; sexp_pairp(ls); ls=sexp_cdr(ls)) + if (! sexp_stringp(sexp_car(ls))) + return sexp_type_exception("not a string", sexp_car(ls)); + else + len += sexp_string_length(sexp_car(ls)); + res = sexp_make_string(sexp_make_integer(len), SEXP_VOID); + p = sexp_string_data(res); + for (ls=str_ls; sexp_pairp(ls); ls=sexp_cdr(ls)) { + len = sexp_string_length(sexp_car(ls)); + memcpy(p, sexp_string_data(sexp_car(ls)), len); + p += len; + } + return res; +} + +static sexp sexp_string_cmp (sexp str1, sexp str2) { + sexp_sint_t len1, len2, len, diff; + if (! sexp_stringp(str1)) + return sexp_type_exception("not a string", str1); + if (! sexp_stringp(str2)) + return sexp_type_exception("not a string", str2); + len1 = sexp_string_length(str1); + len2 = sexp_string_length(str2); + len = ((len1 (cadr cl))) + (list (list (rename 'lambda) (list (rename 'tmp)) + (list (rename 'if) (rename 'tmp) + (if (null? (cdr cl)) + (rename 'tmp) + (list (caddr cl) (rename 'tmp))) + (cons (rename 'cond) (cddr expr)))) + (car cl)) + (list (rename 'if) + (car cl) + (cons (rename 'begin) (cdr cl)) + (cons (rename 'cond) (cddr expr)))))) + (cadr expr)))))) + +(define-syntax or + (er-macro-transformer + (lambda (expr rename compare) + (cond ((null? (cdr expr)) #f) + ((null? (cddr expr)) (cadr expr)) + (else + (list (rename 'let) (list (list (rename 'tmp) (cadr expr))) + (list (rename 'if) (rename 'tmp) + (rename 'tmp) + (cons (rename 'or) (cddr expr))))))))) + +(define-syntax and + (er-macro-transformer + (lambda (expr rename compare) + (cond ((null? (cdr expr))) + ((null? (cddr expr)) (cadr expr)) + (else (list (rename 'if) (cadr expr) + (cons (rename 'and) (cddr expr)) + #f)))))) + +(define-syntax quasiquote + (er-macro-transformer + (lambda (expr rename compare) + (define (qq x d) + (cond + ((pair? x) + (cond + ((eq? 'unquote (car x)) + (if (<= d 0) + (cadr x) + (list (rename 'list) (list (rename 'quote) 'unquote) + (qq (cadr x) (- d 1))))) + ((eq? 'unquote-splicing (car x)) + (if (<= d 0) + (list (rename 'cons) (qq (car x) d) (qq (cdr x) d)) + (list (rename 'list) (list (rename 'quote) 'unquote-splicing) + (qq (cadr x) (- d 1))))) + ((eq? 'quasiquote (car x)) + (list (rename 'list) (list (rename 'quote) 'quasiquote) + (qq (cadr x) (+ d 1)))) + ((and (<= d 0) (pair? (car x)) (eq? 'unquote-splicing (caar x))) + (if (null? (cdr x)) + (cadar x) + (list (rename 'append) (cadar x) (qq (cdr x) d)))) + (else + (list (rename 'cons) (qq (car x) d) (qq (cdr x) d))))) + ((vector? x) (list (rename 'list->vector) (qq (vector->list x) d))) + ((symbol? x) (list (rename 'quote) x)) + (else x))) + (qq (cadr expr) 0)))) + +(define-syntax letrec + (er-macro-transformer + (lambda (expr rename compare) + ((lambda (defs) + `((,(rename 'lambda) () ,@defs ,@(cddr expr)))) + (map (lambda (x) (cons (rename 'define) x)) (cadr expr)))))) + +(define-syntax let + (er-macro-transformer + (lambda (expr rename compare) + (if (identifier? (cadr expr)) + `(,(rename 'letrec) ((,(cadr expr) + (,(rename 'lambda) ,(map car (caddr expr)) + ,@(cdddr expr)))) + ,(cons (cadr expr) (map cadr (caddr expr)))) + `((,(rename 'lambda) ,(map car (cadr expr)) ,@(cddr expr)) + ,@(map cadr (cadr expr))))))) + +(define-syntax let* + (er-macro-transformer + (lambda (expr rename compare) + (if (null? (cadr expr)) + `(,(rename 'begin) ,@(cddr expr)) + `(,(rename 'let) (,(caadr expr)) + (,(rename 'let*) ,(cdadr expr) ,@(cddr expr))))))) + +(define-syntax case + (er-macro-transformer + (lambda (expr rename compare) + (define (clause ls) + (cond + ((null? ls) #f) + ((compare 'else (caar ls)) + `(,(rename 'begin) ,@(cdar ls))) + (else + (if (and (pair? (caar ls)) (null? (cdaar ls))) + `(,(rename 'if) (,(rename 'eqv?) ,(rename 'tmp) ',(caaar ls)) + (,(rename 'begin) ,@(cdar ls)) + ,(clause (cdr ls))) + `(,(rename 'if) (,(rename 'memv) ,(rename 'tmp) ',(caar ls)) + (,(rename 'begin) ,@(cdar ls)) + ,(clause (cdr ls))))))) + `(let ((,(rename 'tmp) ,(cadr expr))) + ,(clause (cddr expr)))))) + +(define-syntax do + (er-macro-transformer + (lambda (expr rename compare) + (let* ((body + `(,(rename 'begin) + ,@(cdddr expr) + (,(rename 'lp) + ,@(map (lambda (x) (if (pair? (cddr x)) (caddr x) (car x))) + (cadr expr))))) + (check (caddr expr)) + (wrap + (if (null? (cdr check)) + `(,(rename 'let) ((,(rename 'tmp) ,(car check))) + (,(rename 'if) ,(rename 'tmp) + ,(rename 'tmp) + ,body)) + `(,(rename 'if) ,(car check) + (,(rename 'begin) ,@(cdr check)) + ,body)))) + `(,(rename 'let) ,(rename 'lp) + ,(map (lambda (x) (list (car x) (cadr x))) (cadr expr)) + ,wrap))))) + +(define-syntax delay + (er-macro-transformer + (lambda (expr rename compare) + `(,(rename 'make-promise) (,(rename 'lambda) () ,(cadr expr)))))) + +(define (make-promise thunk) + (lambda () + (let ((computed? #f) (result #f)) + (if (not computed?) + (begin + (set! result (thunk)) + (set! computed? #t))) + result))) + +(define (force x) (if (procedure? x) (x) x)) + +(define (error msg . args) + (raise (make-exception 'user msg args #f #f #f))) + +(define (with-exception-handler handler thunk) + (let ((orig-handler (current-exception-handler))) + (current-exception-handler handler) + (let ((res (thunk))) + (current-exception-handler orig-handler) + res))) + +;; booleans + +(define (not x) (if x #f #t)) +(define (boolean? x) (if (eq? x #t) #t (eq? x #f))) + +;; char utils + +(define (char-alphabetic? ch) (<= 65 (char->integer (char-upcase ch)) 90)) +(define (char-numeric? ch) (<= 48 (char->integer ch) 57)) +(define (char-whitespace? ch) + (if (eq? ch #\space) + #t + (if (eq? ch #\tab) #t (if (eq? ch #\newline) #t (eq? ch #\return))))) +(define (char-upper-case? ch) (<= 65 (char->integer ch) 90)) +(define (char-lower-case? ch) (<= 97 (char->integer ch) 122)) + +(define (char=? a b) (= (char->integer a) (char->integer b))) +(define (charinteger a) (char->integer b))) +(define (char>? a b) (> (char->integer a) (char->integer b))) +(define (char<=? a b) (<= (char->integer a) (char->integer b))) +(define (char>=? a b) (>= (char->integer a) (char->integer b))) + +(define (char-ci=? a b) + (= (char->integer (char-downcase a)) (char->integer (char-downcase b)))) +(define (char-ciinteger (char-downcase a)) (char->integer (char-downcase b)))) +(define (char-ci>? a b) + (> (char->integer (char-downcase a)) (char->integer (char-downcase b)))) +(define (char-ci<=? a b) + (<= (char->integer (char-downcase a)) (char->integer (char-downcase b)))) +(define (char-ci>=? a b) + (>= (char->integer (char-downcase a)) (char->integer (char-downcase b)))) + +;; string utils + +(define (symbol->string sym) + (call-with-output-string (lambda (out) (write sym out)))) + +(define (list->string ls) + (let ((str (make-string (length ls) #\space))) + (let lp ((ls ls) (i 0)) + (if (pair? ls) + (begin + (string-set! str i (car ls)) + (lp (cdr ls) (+ i 1))))) + str)) + +(define (string->list str) + (let lp ((i (- (string-length str) 1)) (res '())) + (if (< i 0) res (lp (- i 1) (cons (string-ref str i) res))))) + +(define (string-fill! str ch) + (let lp ((i (- (string-length str) 1))) + (if (>= i 0) (begin (string-set! str i ch) (lp (- i 1)))))) + +(define (string . args) (list->string args)) +(define (string-append . args) (string-concatenate args)) +(define (string-copy s) (substring s 0 (string-length s))) + +(define (string=? s1 s2) (eq? (string-cmp s1 s2) 0)) +(define (string? s1 s2) (> (string-cmp s1 s2) 0)) +(define (string>=? s1 s2) (>= (string-cmp s1 s2) 0)) + +(define (string-ci=? s1 s2) (eq? (string-cmp-ci s1 s2) 0)) +(define (string-ci? s1 s2) (> (string-cmp-ci s1 s2) 0)) +(define (string-ci>=? s1 s2) (>= (string-cmp-ci s1 s2) 0)) + +;; list utils + +(define (eqv? a b) (if (eq? a b) #t (and (flonum? a) (flonum? b) (= a b)))) + +(define (member obj ls) + (if (null? ls) + #f + (if (equal? obj (car ls)) + ls + (member obj (cdr ls))))) + +(define memv member) + +(define (assoc obj ls) + (if (null? ls) + #f + (if (equal? obj (caar ls)) + (car ls) + (assoc obj (cdr ls))))) + +(define assv assoc) + +;; math utils + +(define (number? x) (if (fixnum? x) #t (flonum? x))) +(define complex? number?) +(define rational? number?) +(define real? number?) +(define exact? fixnum?) +(define inexact? flonum?) +(define (integer? x) (if (fixnum? x) #t (and (flonum? x) (= x (truncate x))))) + +(define (zero? x) (= x 0)) +(define (positive? x) (> x 0)) +(define (negative? x) (< x 0)) +(define (even? n) (= (remainder n 2) 0)) +(define (odd? n) (= (remainder n 2) 1)) + +(define (abs x) (if (< x 0) (- x) x)) + +(define (modulo a b) + (let ((res (remainder a b))) + (if (< b 0) + (if (<= res 0) res (+ res b)) + (if (>= res 0) res (+ res b))))) + +(define (gcd a b) + (if (= b 0) + (abs a) + (gcd b (remainder a b)))) + +(define (lcm a b) + (abs (quotient (* a b) (gcd a b)))) + +(define (max x . rest) + (let lp ((hi x) (ls rest)) + (if (null? ls) + hi + (lp (if (> (car ls) hi) (car ls) hi) (cdr ls))))) + +(define (min x . rest) + (let lp ((lo x) (ls rest)) + (if (null? ls) + lo + (lp (if (< (car ls) lo) (car ls) lo) (cdr ls))))) + +(define (real-part z) z) +(define (imag-part z) 0.0) +(define magnitude abs) +(define (angle z) (if (< z 0) 3.141592653589793 0)) + +(define (digit-char n) (integer->char (+ n (char->integer #\0)))) +(define (digit-value ch) + (if (char-numeric? ch) + (- (char->integer ch) (char->integer #\0)) + (and (<= 65 (char->integer (char-upcase ch)) 70) + (- (char->integer (char-upcase ch)) 65)))) + +(define (number->string n . o) + (if (if (null? o) #t (eq? 10 (car o))) + (call-with-output-string (lambda (out) (write n out))) + (let lp ((n n) (d (car o)) (res '())) + (if (> n 0) + (lp (quotient n d) d (cons (digit-char (remainder n d)) res)) + (list->string res))))) + +(define (string->number str . o) + (let ((res + (if (if (null? o) #t (eq? 10 (car o))) + (call-with-input-string str (lambda (in) (read in))) + (let ((len (string-length str))) + (let lp ((i 0) (d (car o)) (acc 0)) + (if (>= i len) + acc + (let ((v (digit-value (string-ref str i)))) + (and v (lp (+ i 1) d (+ (* acc d) v)))))))))) + (and (number? res) res))) + +;; vector utils + +(define (list->vector ls) + (let ((vec (make-vector (length ls) #f))) + (let lp ((ls ls) (i 0)) + (if (pair? ls) + (begin + (vector-set! vec i (car ls)) + (lp (cdr ls) (+ i 1))))) + vec)) + +(define (vector->list vec) + (let lp ((i (- (vector-length vec) 1)) (res '())) + (if (< i 0) res (lp (- i 1) (cons (vector-ref vec i) res))))) + +(define (vector-fill! str ch) + (let lp ((i (- (vector-length str) 1))) + (if (>= i 0) (begin (vector-set! str i ch) (lp (- i 1)))))) + +(define (vector . args) (list->vector args)) + +;; I/O utils + +(define (char-ready? . o) + (not (eof-object? (peek-char (if (pair? o) (car o) (current-input-port)))))) + +(define (load file) (%load file (interaction-environment))) + +(define (call-with-input-string str proc) + (proc (open-input-string str))) + +(define (call-with-output-string proc) + (let ((out (open-output-string))) + (proc out) + (get-output-string out))) + +(define (call-with-input-file file proc) + (let* ((in (open-input-file file)) + (res (proc in))) + (close-input-port in) + res)) + +(define (call-with-output-file file proc) + (let* ((out (open-output-file file)) + (res (proc out))) + (close-output-port out) + res)) + +(define (with-input-from-file file thunk) + (let ((old-in (current-input-port)) + (tmp-in (open-input-file file))) + (current-input-port tmp-in) + (let ((res (thunk))) + (current-input-port old-in) + res))) + +(define (with-output-to-file file thunk) + (let ((old-out (current-input-port)) + (tmp-out (open-output-file file))) + (current-input-port tmp-out) + (let ((res (thunk))) + (current-output-port old-out) + res))) + +;; values + +(define *values-tag* (list 'values)) + +(define (values . ls) + (if (and (pair? ls) (null? (cdr ls))) + (car ls) + (cons *values-tag* ls))) + +(define (call-with-values producer consumer) + (let ((res (producer))) + (if (and (pair? res) (eq? *values-tag* (car res))) + (apply consumer (cdr res)) + (consumer res)))) diff --git a/main.c b/main.c new file mode 100644 index 00000000..62da5068 --- /dev/null +++ b/main.c @@ -0,0 +1,110 @@ + +#include "eval.c" + +void repl (sexp context) { + sexp obj, tmp, res, env, in, out, err; + env = sexp_context_env(context); + sexp_context_tracep(context) = 1; + in = env_global_ref(env, the_cur_in_symbol, SEXP_FALSE); + out = env_global_ref(env, the_cur_out_symbol, SEXP_FALSE); + err = env_global_ref(env, the_cur_err_symbol, SEXP_FALSE); + while (1) { + sexp_write_string("> ", out); + sexp_flush(out); + obj = sexp_read(in); + if (obj == SEXP_EOF) + break; + if (sexp_exceptionp(obj)) { + sexp_print_exception(obj, err); + } else { + tmp = sexp_env_bindings(env); + res = eval_in_context(obj, context); +#ifdef USE_WARN_UNDEFS + sexp_warn_undefs(sexp_env_bindings(env), tmp, err); +#endif + if (res != SEXP_VOID) { + sexp_write(res, out); + sexp_write_char('\n', out); + } + } + } +} + +void run_main (int argc, char **argv) { + sexp env, out=NULL, res, context, perr_cell, err_cell, err_handler; + sexp_uint_t i, quit=0, init_loaded=0; + + env = sexp_make_standard_env(sexp_make_integer(5)); + env_define(env, the_interaction_env_symbol, env); + out = env_global_ref(env, the_cur_out_symbol, SEXP_FALSE); + err_cell = env_cell(env, the_cur_err_symbol); + perr_cell = env_cell(env, sexp_intern("print-exception")); + context = sexp_make_context(NULL, env); + sexp_context_tailp(context) = 0; + if (err_cell && perr_cell && sexp_opcodep(sexp_cdr(perr_cell))) { + emit(OP_GLOBAL_KNOWN_REF, context); + emit_word((sexp_uint_t)err_cell, context); + emit(OP_LOCAL_REF, context); + emit_word(0, context); + emit(OP_FCALL2, context); + emit_word((sexp_uint_t)sexp_opcode_data(sexp_cdr(perr_cell)), context); + } + emit_push(SEXP_VOID, context); + emit(OP_DONE, context); + err_handler = sexp_make_procedure(sexp_make_integer(0), + sexp_make_integer(0), + finalize_bytecode(context), + sexp_make_vector(0, SEXP_VOID)); + env_define(env, the_err_handler_symbol, err_handler); + + /* parse options */ + for (i=1; i < argc && argv[i][0] == '-'; i++) { + switch (argv[i][1]) { +#if USE_STRING_STREAMS + case 'e': + case 'p': + if (! init_loaded++) + sexp_load(sexp_c_string(sexp_init_file), env); + res = sexp_read_from_string(argv[i+1]); + if (! sexp_exceptionp(res)) + res = eval_in_context(res, context); + if (sexp_exceptionp(res)) { + sexp_print_exception(res, out); + } else if (argv[i][1] == 'p') { + sexp_write(res, out); + sexp_write_char('\n', out); + } + quit=1; + i++; + break; +#endif + case 'l': + if (! init_loaded++) + sexp_load(sexp_c_string(sexp_init_file), env); + sexp_load(sexp_c_string(argv[++i]), env); + break; + case 'q': + init_loaded = 1; + break; + default: + errx(1, "unknown option: %s", argv[i]); + } + } + + if (! quit) { + if (! init_loaded) + sexp_load(sexp_c_string(sexp_init_file), env); + if (i < argc) + for ( ; i < argc; i++) + sexp_load(sexp_c_string(argv[i]), env); + else + repl(context); + } +} + +int main (int argc, char **argv) { + scheme_init(); + run_main(argc, argv); + return 0; +} + diff --git a/opcodes.c b/opcodes.c new file mode 100644 index 00000000..5bd6cc4a --- /dev/null +++ b/opcodes.c @@ -0,0 +1,130 @@ + +#define _OP(c,o,n,m,t,u,i,s,f,d) \ + {.tag=SEXP_OPCODE, \ + .value={.opcode={c, o, n, m, t, u, i, s, f, d, NULL}}} +#define _FN(o,n,m,t,u,s,f,d) _OP(OPC_FOREIGN, o, n, m, t, u, 0, s, f, (sexp)d) +#define _FN0(s, f, d) _FN(OP_FCALL0, 0, 0, 0, 0, s, f, d) +#define _FN1(t, s, f, d) _FN(OP_FCALL1, 1, 0, t, 0, s, f, d) +#define _FN2(t, u, s, f, d) _FN(OP_FCALL2, 2, 0, t, u, s, f, d) +#define _FN2OPT(t, u, s, f, d) _FN(OP_FCALL2, 1, 1, t, u, s, f, d) +#define _FN3(t, u, s, f, d) _FN(OP_FCALL3, 3, 0, t, u, s, f, d) +#define _FN4(t, u, s, f, d) _FN(OP_FCALL4, 4, 0, t, u, s, f, d) +#define _FN5(t, u, s, f, d) _FN(OP_FCALL5, 5, 0, t, u, s, f, d) +#define _FN6(t, u, s, f, d) _FN(OP_FCALL6, 6, 0, t, u, s, f, d) +#define _PARAM(n, a, t) _OP(OPC_PARAMETER, OP_NOOP, 0, 3, t, 0, 0, n, a, 0) + +static struct sexp_struct opcodes[] = { +_OP(OPC_ACCESSOR, OP_CAR, 1, 0, SEXP_PAIR, 0, 0, "car", 0, NULL), +_OP(OPC_ACCESSOR, OP_SET_CAR, 2, 0, SEXP_PAIR, 0, 0, "set-car!", 0, NULL), +_OP(OPC_ACCESSOR, OP_CDR, 1, 0, SEXP_PAIR, 0, 0, "cdr", 0, NULL), +_OP(OPC_ACCESSOR, OP_SET_CDR, 2, 0, SEXP_PAIR, 0, 0, "set-cdr!", 0, NULL), +_OP(OPC_ACCESSOR, OP_VECTOR_REF,2,0, SEXP_VECTOR, SEXP_FIXNUM, 0,"vector-ref", 0, NULL), +_OP(OPC_ACCESSOR, OP_VECTOR_SET,3,0, SEXP_VECTOR, SEXP_FIXNUM, 0,"vector-set!", 0, NULL), +_OP(OPC_ACCESSOR, OP_VECTOR_LENGTH,1,0, SEXP_VECTOR, 0, 0,"vector-length", 0, NULL), +_OP(OPC_ACCESSOR, OP_STRING_REF,2,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-ref", 0, NULL), +_OP(OPC_ACCESSOR, OP_STRING_SET,3,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-set!", 0, NULL), +_OP(OPC_ACCESSOR, OP_STRING_LENGTH,1,0, SEXP_STRING, 0, 0,"string-length", 0, NULL), +_OP(OPC_GENERIC, OP_FIX2FLO, 1, 0, 0, 0, 0, "exact->inexact", 0, NULL), +_OP(OPC_GENERIC, OP_FLO2FIX, 1, 0, 0, 0, 0, "inexact->exact", 0, NULL), +_OP(OPC_GENERIC, OP_CHAR2INT, 1, 0, SEXP_CHAR, 0, 0, "char->integer", 0, NULL), +_OP(OPC_GENERIC, OP_INT2CHAR, 1, 0, SEXP_FIXNUM, 0, 0, "integer->char", 0, NULL), +_OP(OPC_GENERIC, OP_CHAR_UPCASE, 1, 0, SEXP_CHAR, 0, 0, "char-upcase", 0, NULL), +_OP(OPC_GENERIC, OP_CHAR_DOWNCASE, 1, 0, SEXP_CHAR, 0, 0, "char-downcase", 0, NULL), +_OP(OPC_ARITHMETIC, OP_ADD, 0, 1, SEXP_FIXNUM, 0, 0, "+", sexp_make_integer(0), NULL), +_OP(OPC_ARITHMETIC, OP_MUL, 0, 1, SEXP_FIXNUM, 0, 0, "*", sexp_make_integer(1), NULL), +_OP(OPC_ARITHMETIC_INV, OP_SUB, 0, 1, SEXP_FIXNUM, 0, OP_NEGATIVE, "-", 0, NULL), +_OP(OPC_ARITHMETIC_INV, OP_DIV, 0, 1, SEXP_FIXNUM, 0, OP_INVERSE, "/", 0, NULL), +_OP(OPC_ARITHMETIC, OP_QUOTIENT, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, 0, "quotient", 0, NULL), +_OP(OPC_ARITHMETIC, OP_REMAINDER, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, 0, "remainder", 0, NULL), +_OP(OPC_ARITHMETIC_CMP, OP_LT, 0, 1, SEXP_FIXNUM, 0, 0, "<", 0, NULL), +_OP(OPC_ARITHMETIC_CMP, OP_LE, 0, 1, SEXP_FIXNUM, 0, 0, "<=", 0, NULL), +_OP(OPC_ARITHMETIC_CMP, OP_LT, 0, 1, SEXP_FIXNUM, 0, 1, ">", 0, NULL), +_OP(OPC_ARITHMETIC_CMP, OP_LE, 0, 1, SEXP_FIXNUM, 0, 1, ">=", 0, NULL), +_OP(OPC_ARITHMETIC_CMP, OP_EQN, 0, 1, SEXP_FIXNUM, 0, 0, "=", 0, NULL), +_OP(OPC_PREDICATE, OP_EQ, 2, 0, 0, 0, 0, "eq?", 0, NULL), +_OP(OPC_CONSTRUCTOR, OP_CONS, 2, 0, 0, 0, 0, "cons", 0, NULL), +_OP(OPC_CONSTRUCTOR, OP_MAKE_VECTOR, 1, 1, SEXP_FIXNUM, 0, 0, "make-vector", SEXP_VOID, NULL), +_OP(OPC_CONSTRUCTOR, OP_MAKE_PROCEDURE, 4, 0, 0, 0, 0, "make-procedure", 0, NULL), +_OP(OPC_TYPE_PREDICATE, OP_NULLP, 1, 0, 0, 0, 0, "null?", 0, NULL), +_OP(OPC_TYPE_PREDICATE, OP_EOFP, 1, 0, 0, 0, 0, "eof-object?", 0, NULL), +_OP(OPC_TYPE_PREDICATE, OP_SYMBOLP, 1, 0, 0, 0, 0, "symbol?", 0, NULL), +_OP(OPC_TYPE_PREDICATE, OP_CHARP, 1, 0, 0, 0, 0, "char?", 0, NULL), +_OP(OPC_TYPE_PREDICATE, OP_INTEGERP, 1, 0, 0, 0, 0, "fixnum?", 0, NULL), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "pair?", 0, (sexp)SEXP_PAIR), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "string?", 0, (sexp)SEXP_STRING), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "vector?", 0, (sexp)SEXP_VECTOR), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "flonum?", 0, (sexp)SEXP_FLONUM), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "closure?", 0, (sexp)SEXP_PROCEDURE), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "opcode?", 0, (sexp)SEXP_OPCODE), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "input-port?", 0, (sexp)SEXP_IPORT), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "output-port?", 0, (sexp)SEXP_OPORT), +_OP(OPC_GENERIC, OP_APPLY1, 2, 0, SEXP_PROCEDURE, SEXP_PAIR, 0, "apply1", 0, NULL), +_OP(OPC_GENERIC, OP_CALLCC, 1, SEXP_PROCEDURE, 0, 0, 0, "call-with-current-continuation", 0, NULL), +_OP(OPC_GENERIC, OP_RAISE, 1, SEXP_STRING, 0, 0, 0, "raise", 0, NULL), +_OP(OPC_IO, OP_WRITE, 1, 3, 0, SEXP_OPORT, 0, "write", (sexp)"*current-output-port*", NULL), +_OP(OPC_IO, OP_DISPLAY, 1, 3, 0, SEXP_OPORT, 0, "display", (sexp)"*current-output-port*", NULL), +_OP(OPC_IO, OP_WRITE_CHAR, 1, 3, 0, SEXP_OPORT, 0, "write-char", (sexp)"*current-output-port*", NULL), +_OP(OPC_IO, OP_NEWLINE, 0, 3, 0, SEXP_OPORT, 0, "newline", (sexp)"*current-output-port*", NULL), +_OP(OPC_IO, OP_FLUSH_OUTPUT, 0, 3, 0, SEXP_OPORT, 0, "flush-output", (sexp)"*current-output-port*", NULL), +_OP(OPC_IO, OP_READ, 0, 3, 0, SEXP_IPORT, 0, "read", (sexp)"*current-input-port*", NULL), +_OP(OPC_IO, OP_READ_CHAR, 0, 3, 0, SEXP_IPORT, 0, "read-char", (sexp)"*current-input-port*", NULL), +_OP(OPC_IO, OP_PEEK_CHAR, 0, 3, 0, SEXP_IPORT, 0, "peek-char", (sexp)"*current-input-port*", NULL), +_OP(OPC_GENERIC, OP_EVAL, 1, 3, 0, 0, 0, "eval", (sexp)"*interaction-environment*", NULL), +_FN2(0, 0, "equal?", 0, sexp_equalp), +_FN1(0, "list?", 0, sexp_listp), +_FN1(0, "identifier?", 0, sexp_identifierp), +_FN1(0, "identifier->symbol", 0, sexp_syntactic_closure_expr), +_FN4(0, SEXP_ENV, "identifier=?", 0, sexp_identifier_eq), +_FN1(SEXP_PAIR, "length", 0, sexp_length), +_FN1(SEXP_PAIR, "reverse", 0, sexp_reverse), +_FN1(SEXP_PAIR, "list->vector", 0, sexp_list_to_vector), +_FN1(SEXP_STRING, "open-input-file", 0, sexp_open_input_file), +_FN1(SEXP_STRING, "open-output-file", 0, sexp_open_output_file), +_FN1(SEXP_IPORT, "close-input-port", 0, sexp_close_port), +_FN1(SEXP_OPORT, "close-output-port", 0, sexp_close_port), +_FN1(SEXP_FIXNUM, "null-environment", 0, sexp_make_null_env), +_FN1(SEXP_FIXNUM, "scheme-report-environment", 0, sexp_make_standard_env), +_FN2(SEXP_STRING, SEXP_ENV, "%load", 0, sexp_load), +_FN2(SEXP_EXCEPTION, SEXP_OPORT, "print-exception", 0, sexp_print_exception), +_FN1(SEXP_EXCEPTION, "exception-type", 0, sexp_exception_type_func), +_FN6(SEXP_SYMBOL, SEXP_STRING, "make-exception", 0, sexp_make_exception), +_FN2OPT(SEXP_FIXNUM, SEXP_CHAR, "make-string", sexp_make_character(' '), sexp_make_string), +_FN2(SEXP_STRING, SEXP_STRING, "string-cmp", 0, sexp_string_cmp), +_FN2(SEXP_STRING, SEXP_STRING, "string-cmp-ci", 0, sexp_string_cmp_ci), +_FN3(SEXP_STRING, SEXP_FIXNUM, "substring", 0, sexp_substring), +_FN1(SEXP_STRING, "string->symbol", 0, sexp_string_to_symbol), +_FN1(SEXP_PAIR, "string-concatenate", 0, sexp_string_concatenate), +_FN2(0, SEXP_PAIR, "memq", 0, sexp_memq), +_FN2(0, SEXP_PAIR, "assq", 0, sexp_assq), +_FN3(SEXP_ENV, SEXP_PAIR, "make-syntactic-closure", 0, sexp_make_synclo), +_PARAM("current-input-port", (sexp)"*current-input-port*", SEXP_IPORT), +_PARAM("current-output-port", (sexp)"*current-output-port*", SEXP_OPORT), +_PARAM("current-error-port", (sexp)"*current-error-port*", SEXP_OPORT), +_PARAM("current-exception-handler", (sexp)"*current-exception-handler*", SEXP_PROCEDURE), +_PARAM("interaction-environment", (sexp)"*interaction-environment*", SEXP_ENV), +#if USE_MATH +_FN1(0, "exp", 0, sexp_exp), +_FN1(0, "log", 0, sexp_log), +_FN1(0, "sin", 0, sexp_sin), +_FN1(0, "cos", 0, sexp_cos), +_FN1(0, "tan", 0, sexp_tan), +_FN1(0, "asin", 0, sexp_asin), +_FN1(0, "acos", 0, sexp_acos), +_FN1(0, "atan", 0, sexp_atan), +_FN1(0, "sqrt", 0, sexp_sqrt), +_FN1(0, "round", 0, sexp_round), +_FN1(0, "truncate", 0, sexp_trunc), +_FN1(0, "floor", 0, sexp_floor), +_FN1(0, "ceiling", 0, sexp_ceiling), +_FN2(0, 0, "expt", 0, sexp_expt), +#endif +#if USE_STRING_STREAMS +_FN0("open-output-string", 0, sexp_make_output_string_port), +_FN1(SEXP_STRING, "open-input-string", 0, sexp_make_input_string_port), +_FN1(SEXP_OPORT, "get-output-string", 0, sexp_get_output_string), +#endif +#if USE_DEBUG +_FN2(SEXP_PROCEDURE, SEXP_OPORT, "disasm", 0, sexp_disasm), +#endif +}; + diff --git a/sexp-huff.c b/sexp-huff.c new file mode 100644 index 00000000..abf6bc9f --- /dev/null +++ b/sexp-huff.c @@ -0,0 +1,128 @@ + {12, 0x0C00}, /* '\x00' */ + {15, 0x0000}, /* '\x01' */ + {15, 0x4000}, /* '\x02' */ + {15, 0x2000}, /* '\x03' */ + {15, 0x6000}, /* '\x04' */ + {15, 0x0800}, /* '\x05' */ + {15, 0x4800}, /* '\x06' */ + {15, 0x2800}, /* '\x07' */ + {15, 0x6800}, /* '\x08' */ + {15, 0x1800}, /* '\x09' */ + {15, 0x5800}, /* '\x0a' */ + {15, 0x3800}, /* '\x0b' */ + {15, 0x7800}, /* '\x0c' */ + {15, 0x0100}, /* '\x0d' */ + {15, 0x4100}, /* '\x0e' */ + {15, 0x2100}, /* '\x0f' */ + {15, 0x6100}, /* '\x10' */ + {15, 0x1100}, /* '\x11' */ + {15, 0x5100}, /* '\x12' */ + {15, 0x3100}, /* '\x13' */ + {15, 0x7100}, /* '\x14' */ + {15, 0x0900}, /* '\x15' */ + {15, 0x4900}, /* '\x16' */ + {15, 0x2900}, /* '\x17' */ + {15, 0x6900}, /* '\x18' */ + {15, 0x1900}, /* '\x19' */ + {15, 0x5900}, /* '\x1a' */ + {15, 0x3900}, /* '\x1b' */ + {15, 0x7900}, /* '\x1c' */ + {15, 0x0500}, /* '\x1d' */ + {15, 0x4500}, /* '\x1e' */ + {15, 0x2500}, /* '\x1f' */ + {15, 0x6500}, /* '\x20' */ + { 8, 0x0040}, /* '!' */ + {15, 0x1500}, /* '"' */ + {15, 0x5500}, /* '#' */ + {15, 0x3500}, /* '$' */ + {15, 0x7500}, /* '%' */ + {15, 0x0D00}, /* '&' */ + {15, 0x4D00}, /* '\'' */ + {15, 0x2D00}, /* '(' */ + {15, 0x6D00}, /* ')' */ + {11, 0x0300}, /* '*' */ + {10, 0x0180}, /* '+' */ + {15, 0x1D00}, /* ',' */ + { 4, 0x000D}, /* '-' */ + {15, 0x5D00}, /* '.' */ + {10, 0x0380}, /* '/' */ + {15, 0x3D00}, /* '0' */ + {15, 0x7D00}, /* '1' */ + {14, 0x0080}, /* '2' */ + {14, 0x2080}, /* '3' */ + {14, 0x1080}, /* '4' */ + {14, 0x3080}, /* '5' */ + {14, 0x0880}, /* '6' */ + {14, 0x2880}, /* '7' */ + {14, 0x1880}, /* '8' */ + {14, 0x3880}, /* '9' */ + {14, 0x0480}, /* ':' */ + {14, 0x2480}, /* ';' */ + { 7, 0x0050}, /* '<' */ + { 7, 0x0042}, /* '=' */ + { 7, 0x0022}, /* '>' */ + { 5, 0x0009}, /* '?' */ + {14, 0x1480}, /* '@' */ + {14, 0x3480}, /* 'A' */ + {14, 0x0C80}, /* 'B' */ + {14, 0x2C80}, /* 'C' */ + {14, 0x1C80}, /* 'D' */ + {14, 0x3C80}, /* 'E' */ + {14, 0x0280}, /* 'F' */ + {14, 0x2280}, /* 'G' */ + {14, 0x1280}, /* 'H' */ + {14, 0x3280}, /* 'I' */ + {14, 0x0A80}, /* 'J' */ + {14, 0x2A80}, /* 'K' */ + {14, 0x1A80}, /* 'L' */ + {14, 0x3A80}, /* 'M' */ + {14, 0x0680}, /* 'N' */ + {14, 0x2680}, /* 'O' */ + {14, 0x1680}, /* 'P' */ + {14, 0x3680}, /* 'Q' */ + {14, 0x0E80}, /* 'R' */ + {14, 0x2E80}, /* 'S' */ + {14, 0x1E80}, /* 'T' */ + {14, 0x3E80}, /* 'U' */ + {14, 0x0200}, /* 'V' */ + {14, 0x2200}, /* 'W' */ + {14, 0x1200}, /* 'X' */ + {14, 0x3200}, /* 'Y' */ + {14, 0x0A00}, /* 'Z' */ + {14, 0x2A00}, /* '[' */ + {14, 0x1A00}, /* '\\' */ + {14, 0x3A00}, /* ']' */ + {14, 0x0600}, /* '^' */ + {14, 0x2600}, /* '_' */ + {14, 0x1600}, /* '`' */ + { 3, 0x0007}, /* 'a' */ + { 7, 0x0020}, /* 'b' */ + { 4, 0x0004}, /* 'c' */ + { 5, 0x001A}, /* 'd' */ + { 4, 0x0006}, /* 'e' */ + { 7, 0x0002}, /* 'f' */ + { 5, 0x0011}, /* 'g' */ + { 6, 0x0012}, /* 'h' */ + { 4, 0x000C}, /* 'i' */ + {12, 0x0400}, /* 'j' */ + { 8, 0x00C0}, /* 'k' */ + { 5, 0x0018}, /* 'l' */ + { 6, 0x0032}, /* 'm' */ + { 4, 0x0005}, /* 'n' */ + { 5, 0x000A}, /* 'o' */ + { 5, 0x0001}, /* 'p' */ + { 7, 0x0070}, /* 'q' */ + { 3, 0x0003}, /* 'r' */ + { 5, 0x0008}, /* 's' */ + { 4, 0x000E}, /* 't' */ + { 5, 0x0019}, /* 'u' */ + { 7, 0x0062}, /* 'v' */ + { 7, 0x0030}, /* 'w' */ + { 7, 0x0060}, /* 'x' */ + { 7, 0x0010}, /* 'y' */ + {11, 0x0700}, /* 'z' */ + {14, 0x3600}, /* '{' */ + {14, 0x0E00}, /* '|' */ + {14, 0x2E00}, /* '}' */ + {14, 0x1E00}, /* '~' */ + {14, 0x3E00}, /* '\x7f' */ diff --git a/sexp-hufftabs.c b/sexp-hufftabs.c new file mode 100644 index 00000000..7704184f --- /dev/null +++ b/sexp-hufftabs.c @@ -0,0 +1,92 @@ +/* auto-generated by ./symhuff.scm on Sun Feb 25 23:12:52 2007 */ + +char _huff_tab21[] = { + '\x01', '\x00', '\x03', '\x00', '\x02', '\x00', '\x04', '\x00', +}; + +char _huff_tab19[] = { + '\x01', 'j', '\x01', '\x00', +}; + +char _huff_tab20[] = { + '\x05', '\x09', '\x07', '\x0b', '\x06', '\x0a', '\x08', '\x0c', +}; + +char _huff_tab18[] = { + '2', ':', '6', 'B', '4', '@', '8', 'D', + '3', ';', '7', 'C', '5', 'A', '9', 'E', +}; + +char _huff_tab17[] = { + '\x0d', '\x1d', '\x15', '&', '\x11', '"', '\x19', ',', + '\x0f', '\x1f', '\x17', '(', '\x13', '$', '\x1b', '0', + '\x0e', '\x1e', '\x16', '\'', '\x12', '#', '\x1a', '.', + '\x10', '\x20', '\x18', ')', '\x14', '%', '\x1c', '1', +}; + +char _huff_tab16[] = { + 'V', '^', 'Z', '|', 'X', '`', '\\', '~', + 'W', '_', '[', '}', 'Y', '{', ']', '\x7f', +}; + +char _huff_tab15[] = { + 'F', 'N', 'J', 'R', 'H', 'P', 'L', 'T', + 'G', 'O', 'K', 'S', 'I', 'Q', 'M', 'U', +}; + +char _huff_tab13[] = { + '\x00', '\x00', '\x00', '+', '\x00', '\x00', '\x00', '/', +}; + +char _huff_tab14[] = { + '*', 'z', +}; + +char _huff_tab11[] = { + '\x00', 'b', '\x00', 'x', +}; + +char _huff_tab12[] = { + '!', 'k', +}; + +char _huff_tab9[] = { + '\x00', 's', '\x00', 'l', +}; + +char _huff_tab10[] = { + 'y', 'w', '<', 'q', +}; + +char _huff_tab8[] = { + 'p', '?', 'g', 'u', +}; + +char _huff_tab7[] = { + 'f', '>', '=', 'v', +}; + +char _huff_tab5[] = { + '\x00', 'o', '\x00', 'd', +}; + +char _huff_tab6[] = { + 'h', 'm', +}; + +char _huff_tab4[] = { + 'c', 'i', +}; + +char _huff_tab3[] = { + 'n', '-', +}; + +char _huff_tab1[] = { + '\x00', '\x00', '\x00', 'r', '\x00', '\x00', '\x00', 'a', +}; + +char _huff_tab2[] = { + 'e', 't', +}; + diff --git a/sexp-unhuff.c b/sexp-unhuff.c new file mode 100644 index 00000000..fa142e16 --- /dev/null +++ b/sexp-unhuff.c @@ -0,0 +1,71 @@ +/* auto-generated by ./symhuff.scm on Sun Feb 25 23:12:52 2007 */ + +res = c & 7; +c = c >> 3; +if (res == 0) { + res = c & 3; + c = c >> 2; + if (res == 0) { + res = c & 3; + c = c >> 2; + if (res == 0) { + res = c & 7; + c = c >> 3; + if (res == 0) { + res = c & 3; + c = c >> 2; + if (res == 0) { + res = _huff_tab21[c & 7]; + c = c >> 3; + } else if ((res = _huff_tab19[res]) == '\x01') { + res = _huff_tab20[c & 7]; + c = c >> 3; + } + } else if (res == 1) { + res = _huff_tab18[c & 15]; + c = c >> 4; + } else if (res == 2) { + res = _huff_tab17[c & 31]; + c = c >> 5; + } else if (res == 4) { + res = _huff_tab16[c & 15]; + c = c >> 4; + } else if (res == 5) { + res = _huff_tab15[c & 15]; + c = c >> 4; + } else if ((res = _huff_tab13[res]) == '\x00') { + res = _huff_tab14[c & 1]; + c = c >> 1; + } + } else if ((res = _huff_tab11[res]) == '\x00') { + res = _huff_tab12[c & 1]; + c = c >> 1; + } + } else if ((res = _huff_tab9[res]) == '\x00') { + res = _huff_tab10[c & 3]; + c = c >> 2; + } + } else if (res == 1) { + res = _huff_tab8[c & 3]; + c = c >> 2; + } else if (res == 2) { + res = c & 3; + c = c >> 2; + if (res == 0) { + res = _huff_tab7[c & 3]; + c = c >> 2; + } else if ((res = _huff_tab5[res]) == '\x00') { + res = _huff_tab6[c & 1]; + c = c >> 1; + } + } else if (res == 4) { + res = _huff_tab4[c & 1]; + c = c >> 1; + } else if (res == 5) { + res = _huff_tab3[c & 1]; + c = c >> 1; + } else if ((res = _huff_tab1[res]) == '\x00') { + res = _huff_tab2[c & 1]; + c = c >> 1; + } + diff --git a/sexp.c b/sexp.c new file mode 100644 index 00000000..f8b4a459 --- /dev/null +++ b/sexp.c @@ -0,0 +1,1147 @@ +/* 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_ */ +}; + +static int digit_value (c) { + return (((c)<='9') ? ((c) - '0') : ((toupper(c) - 'A') + 10)); +} + +static int is_separator(int c) { + /* return (!((c-9)&(~3))) | (~(c^4)); */ + return 0 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_exception_irritants(exn) + && 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_char('\n', out); + } + } + } else { + sexp_write_char('\n', out); + } + } else { + sexp_write_string(": ", out); + if (sexp_stringp(exn)) + sexp_write_string(sexp_string_data(exn), out); + else + sexp_write(exn, out); + sexp_write_char('\n', out); + } + return SEXP_VOID; +} + +static sexp sexp_read_error (char *message, sexp irritants, sexp port) { + sexp name = (sexp_port_name(port) + ? sexp_c_string(sexp_port_name(port)) : SEXP_FALSE); + return sexp_make_exception(the_read_error_symbol, + sexp_c_string(message), + irritants, + SEXP_FALSE, + name, + 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; +} + +sexp sexp_listp (sexp hare) { + sexp turtle; + if (! sexp_pairp(hare)) + return sexp_make_boolean(hare == SEXP_NULL); + turtle = hare; + hare = sexp_cdr(hare); + for ( ; sexp_pairp(hare); turtle=sexp_cdr(turtle)) { + if (hare == turtle) return SEXP_FALSE; + hare = sexp_cdr(hare); + if (sexp_pairp(hare)) hare = sexp_cdr(hare); + } + return sexp_make_boolean(hare == SEXP_NULL); +} + +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 (sexp_pairp(sexp_car(ls)) && (x == sexp_caar(ls))) + return sexp_car(ls); + else + ls = sexp_cdr(ls); + return SEXP_FALSE; +} + +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); +} + +sexp sexp_equalp (sexp a, sexp b) { + sexp_uint_t len; + sexp *v1, *v2; + loop: + if (a == b) + return SEXP_TRUE; + if (! sexp_pointerp(a)) + return sexp_make_boolean(sexp_integerp(a) && sexp_pointerp(b) + && (sexp_unbox_integer(a) + == sexp_flonum_value(b))); + else if (! sexp_pointerp(b)) + return sexp_make_boolean(sexp_integerp(b) && sexp_pointerp(a) + && (sexp_unbox_integer(b) + == sexp_flonum_value(a))); + if (sexp_pointer_tag(a) != sexp_pointer_tag(b)) + return SEXP_FALSE; + switch (sexp_pointer_tag(a)) { + case SEXP_PAIR: + if (sexp_equalp(sexp_car(a), sexp_car(b)) == SEXP_FALSE) + return SEXP_FALSE; + a = sexp_cdr(a); + b = sexp_cdr(b); + goto loop; + case SEXP_VECTOR: + len = sexp_vector_length(a); + if (len != sexp_vector_length(b)) + return SEXP_FALSE; + v1 = sexp_vector_data(a); + v2 = sexp_vector_data(b); + for (len--; len > 0; len--) + if (sexp_equalp(v1[len], v2[len]) == SEXP_FALSE) + return SEXP_FALSE; + return SEXP_TRUE; + case SEXP_STRING: + return sexp_make_boolean((sexp_string_length(a) == sexp_string_length(b)) + && (! strncmp(sexp_string_data(a), + sexp_string_data(b), + sexp_string_length(a)))); + case SEXP_FLONUM: + return sexp_make_boolean(sexp_flonum_value(a) == sexp_flonum_value(b)); + default: + return SEXP_FALSE; + } +} + +/********************* 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(sexp len, sexp ch) { + char *cstr; + sexp s = sexp_alloc_type(string, SEXP_STRING); + sexp_sint_t clen = sexp_unbox_integer(len); + if (clen < 0) return sexp_type_exception("negative length", len); + cstr = sexp_alloc(clen+1); + if (sexp_charp(ch)) + memset(cstr, sexp_unbox_character(ch), clen); + cstr[clen] = '\0'; + sexp_string_length(s) = clen; + sexp_string_data(s) = cstr; + return s; +} + +sexp sexp_c_string(char *str) { + sexp_uint_t len = strlen(str); + sexp s = sexp_make_string(sexp_make_integer(len), SEXP_VOID); + memcpy(sexp_string_data(s), str, len); + return s; +} + +sexp sexp_substring (sexp str, sexp start, sexp end) { + sexp res; + if (! sexp_stringp(str)) + return sexp_type_exception("not a string", str); + if (! sexp_integerp(start)) + return sexp_type_exception("not a number", start); + if (end == SEXP_FALSE) + end = sexp_make_integer(sexp_string_length(str)); + if (! sexp_integerp(end)) + return sexp_type_exception("not a number", end); + if ((sexp_unbox_integer(start) < 0) + || (sexp_unbox_integer(start) > sexp_string_length(str)) + || (sexp_unbox_integer(end) < 0) + || (sexp_unbox_integer(end) > sexp_string_length(str)) + || (end < start)) + return sexp_range_exception(str, start, end); + res = sexp_make_string(sexp_fx_sub(end, start), + SEXP_VOID); + memcpy(sexp_string_data(res), + sexp_string_data(str)+sexp_unbox_integer(start), + sexp_string_length(res)); + return res; +} + +#define FNV_PRIME 16777619 +#define FNV_OFFSET_BASIS 2166136261uL + +sexp_uint_t sexp_string_hash(char *str, sexp_uint_t 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, bucket; + char c, *mystr, *p=str; + sexp sym, ls; + +#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: +#if USE_HASH_SYMS + bucket = (sexp_string_hash(p, res) % SEXP_SYMBOL_TABLE_SIZE); +#else + bucket = 0; +#endif + len = strlen(str); + for (ls=symbol_table[bucket]; sexp_pairp(ls); ls=sexp_cdr(ls)) + if (strncmp(str, sexp_symbol_data(sexp_car(ls)), len) == 0) + return sexp_car(ls); + + /* not found, make a new symbol */ + sym = sexp_alloc_type(symbol, SEXP_SYMBOL); + mystr = sexp_alloc(len+1); + memcpy(mystr, str, len+1); + mystr[len]=0; + sexp_symbol_length(sym) = len; + sexp_symbol_data(sym) = mystr; + sexp_push(symbol_table[bucket], sym); + return sym; +} + +sexp sexp_string_to_symbol (sexp str) { + return sexp_intern(sexp_string_data(str)); +} + +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= len) return 0; + if (n > (len - pos)) n = (len - pos); + memcpy(dst, sexp_string_data(sexp_stream_buf(vec))+pos, n); + sexp_stream_pos(vec) = sexp_make_integer(n); + return n; +} + +int sstream_write (void *vec, const char *src, int n) { + sexp_uint_t len, pos, newpos; + sexp newbuf; + len = sexp_unbox_integer(sexp_stream_size(vec)); + pos = sexp_unbox_integer(sexp_stream_pos(vec)); + newpos = pos+n; + if (newpos >= len) { + newbuf = sexp_make_string(sexp_make_integer(newpos*2), SEXP_VOID); + memcpy(sexp_string_data(newbuf), + sexp_string_data(sexp_stream_buf(vec)), + pos); + sexp_stream_buf(vec) = newbuf; + sexp_stream_size(vec) = sexp_make_integer(newpos*2); + } + memcpy(sexp_string_data(sexp_stream_buf(vec))+pos, src, n); + sexp_stream_pos(vec) = sexp_make_integer(newpos); + return n; +} + +off_t sstream_seek (void *vec, off_t offset, int whence) { + sexp_sint_t pos; + if (whence == SEEK_SET) { + pos = offset; + } else if (whence == SEEK_CUR) { + pos = sexp_unbox_integer(sexp_stream_pos(vec)) + offset; + } else { /* SEEK_END */ + pos = sexp_unbox_integer(sexp_stream_size(vec)) + offset; + } + sexp_stream_pos(vec) = sexp_make_integer(pos); + return pos; +} + +sexp sexp_make_input_string_port (sexp str) { + FILE *in; + sexp res, cookie; + cookie = sexp_vector(3, str, sexp_make_integer(sexp_string_length(str)), + sexp_make_integer(0)); + in = funopen(cookie, &sstream_read, NULL, &sstream_seek, NULL); + res = sexp_make_input_port(in, NULL); + sexp_port_cookie(res) = cookie; + return res; +} + +sexp sexp_make_output_string_port () { + FILE *out; + sexp res, size, cookie; + size = sexp_make_integer(SEXP_INIT_STRING_PORT_SIZE); + cookie = sexp_vector(3, sexp_make_string(size, SEXP_VOID), + size, sexp_make_integer(0)); + out = funopen(cookie, NULL, &sstream_write, &sstream_seek, NULL); + res = sexp_make_output_port(out, NULL); + sexp_port_cookie(res) = cookie; + return res; +} + +sexp sexp_get_output_string (sexp port) { + sexp cookie = sexp_port_cookie(port); + fflush(sexp_port_stream(port)); + return sexp_substring(sexp_stream_buf(cookie), + sexp_make_integer(0), + sexp_stream_pos(cookie)); +} + +#else + +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, NULL); +} + +sexp sexp_make_output_string_port () { + FILE *out; + sexp buf = sexp_alloc_type(string, SEXP_STRING), res; + out = open_memstream(&sexp_string_data(buf), &sexp_string_length(buf)); + res = sexp_make_input_port(out, NULL); + sexp_port_cookie(res) = buf; + return res; +} + +sexp sexp_get_output_string (sexp port) { + sexp cookie = sexp_port_cookie(port); + fflush(sexp_port_stream(port)); + return sexp_substring(cookie, + sexp_make_integer(0), + sexp_make_integer(sexp_string_length(cookie))); +} + +#endif + +#endif + +sexp sexp_make_input_port (FILE* in, char *path) { + sexp p = sexp_alloc_type(port, SEXP_IPORT); + sexp_port_stream(p) = in; + sexp_port_name(p) = path; + sexp_port_line(p) = 0; + return p; +} + +sexp sexp_make_output_port (FILE* out, char *path) { + sexp p = sexp_alloc_type(port, SEXP_OPORT); + sexp_port_stream(p) = out; + sexp_port_name(p) = path; + sexp_port_line(p) = 0; + return p; +} + +void sexp_write (sexp obj, sexp out) { + unsigned long len, c, res; + long i=0; + double f; + sexp x, *elts; + char *str=NULL; + + if (! obj) { + sexp_write_string("#", 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", out); + break; + case SEXP_IPORT: + sexp_write_string("#", out); break; + case SEXP_OPORT: + sexp_write_string("#", out); break; + case SEXP_CORE: + sexp_write_string("#", out); break; + case SEXP_OPCODE: + sexp_write_string("#", out); break; + case SEXP_BYTECODE: + sexp_write_string("#", out); break; + case SEXP_ENV: + sexp_printf(out, "#", obj); break; + case SEXP_EXCEPTION: + sexp_write_string("#", out); break; + case SEXP_MACRO: + sexp_write_string("#", out); break; +#if USE_DEBUG + case SEXP_LAMBDA: + sexp_write_string("#', out); + break; + case SEXP_SEQ: + sexp_write_string("#', out); + break; + case SEXP_CND: + sexp_write_string("#', out); + break; + case SEXP_REF: + sexp_write_string("#", sexp_ref_loc(obj)); + break; + case SEXP_SET: + sexp_write_string("#", out); + break; + case SEXP_SYNCLO: + sexp_write_string("#", out); + break; +#endif + case SEXP_STRING: + sexp_write_char('"', out); + i = sexp_string_length(obj); + str = sexp_string_data(obj); + for ( ; i>0; str++, i--) { + switch (str[0]) { + case '\\': sexp_write_string("\\\\", out); break; + case '"': sexp_write_string("\\\"", out); break; + case '\n': sexp_write_string("\\n", out); break; + case '\r': sexp_write_string("\\r", out); break; + case '\t': sexp_write_string("\\t", out); break; + default: sexp_write_char(str[0], out); + } + } + sexp_write_char('"', out); + break; + case SEXP_SYMBOL: + i = sexp_symbol_length(obj); + str = sexp_symbol_data(obj); + for ( ; i>0; str++, i--) { + if ((str[0] == '\\') || is_separator(str[0])) + sexp_write_char('\\', out); + sexp_write_char(str[0], out); + } + break; + } + } else if (sexp_integerp(obj)) { + sexp_printf(out, "%ld", sexp_unbox_integer(obj)); + } else if (sexp_charp(obj)) { + if (obj == sexp_make_character(' ')) + sexp_write_string("#\\space", out); + else if (obj == sexp_make_character('\n')) + sexp_write_string("#\\newline", out); + else if (obj == sexp_make_character('\r')) + sexp_write_string("#\\return", out); + else if (obj == sexp_make_character('\t')) + sexp_write_string("#\\tab", out); + else 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("#", out); break; + case (sexp_uint_t) SEXP_UNDEF: + case (sexp_uint_t) SEXP_VOID: + sexp_write_string("#", out); break; + case (sexp_uint_t) SEXP_ERROR: + sexp_write_string("#", out); break; + default: + sexp_printf(out, "#", obj); + } + } +} + +char* sexp_read_string(sexp in) { + char *buf, *tmp, *res; + int c, i=0, size=128; + + buf = sexp_alloc(size); + + for (c=sexp_read_char(in); c != '"'; c=sexp_read_char(in)) { + if (c == EOF) { + sexp_free(buf); + return NULL; + } + if (c == '\\') { + c=sexp_read_char(in); + switch (c) { + case 'n': c = '\n'; break; + case 't': c = '\t'; break; + } + buf[i++] = c; + } else { + buf[i++] = c; + } + if (i >= size) { + tmp = sexp_alloc(2*size); + memcpy(tmp, buf, i); + sexp_free(buf); + buf = tmp; + } + } + + buf[i] = '\0'; + res = sexp_alloc(i); + memcpy(res, buf, i); + sexp_free(buf); + return res; +} + +char* sexp_read_symbol(sexp in, int init) { + char *buf, *tmp, *res; + int c, i=0, size=128; + + buf = sexp_alloc(size); + + if (init != EOF) + buf[i++] = init; + + while (1) { + c=sexp_read_char(in); + if (c == EOF || is_separator(c)) { + sexp_push_char(c, in); + break; + } + buf[i++] = c; + if (i >= size) { + tmp = sexp_alloc(2*size); + memcpy(tmp, buf, i); + sexp_free(buf); + buf = tmp; + } + } + + buf[i] = '\0'; + res = sexp_alloc(i); + memcpy(res, buf, i); + sexp_free(buf); + return res; +} + +sexp sexp_read_float_tail(sexp in, sexp_sint_t whole) { + sexp exponent; + double res=0.0, scale=0.1, e=0.0; + 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); + if (c=='e' || c=='E') { + exponent = sexp_read_number(in, 10); + if (sexp_exceptionp(exponent)) return exponent; + e = (sexp_integerp(exponent) ? sexp_unbox_integer(exponent) + : sexp_flonump(exponent) ? sexp_flonum_value(exponent) : 0.0); + } else if ((c!=EOF) && ! is_separator(c)) + return sexp_read_error("invalid numeric syntax", + sexp_list1(sexp_make_character(c)), in); + return sexp_make_flonum((whole + res) * pow(10, e)); +} + +sexp sexp_read_number(sexp in, int base) { + sexp f; + sexp_sint_t res = 0, negativep = 0, c; + + c = sexp_read_char(in); + if (c == '-') + negativep = 1; + else if (isdigit(c)) + res = digit_value(c); + + if (base == 16) + for (c=sexp_read_char(in); isxdigit(c); c=sexp_read_char(in)) + res = res * base + digit_value(c); + for (c=sexp_read_char(in); isdigit(c); c=sexp_read_char(in)) + res = res * base + digit_value(c); + + if (c=='.' || c=='e' || c=='E') { + if (base != 10) + return sexp_read_error("decimal found in non-base 10", SEXP_NULL, in); + if (c!='.') + sexp_push_char(c, in); + f = sexp_read_float_tail(in, res); + if (! sexp_flonump(f)) return f; + if ((c!='.') && (sexp_flonum_value(f) == round(sexp_flonum_value(f)))) { + res = (sexp_sint_t) sexp_flonum_value(f); + } else { + if (negativep) sexp_flonum_value(f) = -sexp_flonum_value(f); + return f; + } + } else { + sexp_push_char(c, in); + if ((c!=EOF) && ! is_separator(c)) + return sexp_read_error("invalid numeric syntax", + sexp_list1(sexp_make_character(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); + if (! str) + res = sexp_read_error("premature end of string", SEXP_NULL, in); + else + res = sexp_c_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': + res = sexp_read(in); + if (sexp_flonump(res)) + res = sexp_make_integer((sexp_sint_t)sexp_flonum_value(res)); + break; + case 'i': + res = sexp_read(in); + if (sexp_integerp(res)) + res = sexp_make_flonum(sexp_unbox_integer(res)); + break; + case 'f': + case 't': + c2 = sexp_read_char(in); + if (c2 == EOF || is_separator(c2)) { + res = (c1 == 't' ? SEXP_TRUE : SEXP_FALSE); + sexp_push_char(c2, in); + } else { + res = sexp_read_error("invalid syntax #%c%c", + sexp_list2(sexp_make_character(c1), + sexp_make_character(c2)), + in); + } + break; + case ';': + sexp_read_raw(in); + goto scan_loop; + case '\\': + c1 = sexp_read_char(in); + str = sexp_read_symbol(in, c1); + if (str[0] == '\0') + res = + sexp_read_error("unexpected end of character literal", SEXP_NULL, in); + if (str[1] == '\0') { + res = sexp_make_character(c1); + } else if ((c1 == 'x' || c1 == 'X') && + isxdigit(str[0]) && isxdigit(str[1]) && str[2] == '\0') { + res = sexp_make_character(16 * digit_value(c1) + digit_value(str[1])); + } else { + if (strcasecmp(str, "space") == 0) + res = sexp_make_character(' '); + else if (strcasecmp(str, "newline") == 0) + res = sexp_make_character('\n'); + else if (strcasecmp(str, "return") == 0) + res = sexp_make_character('\r'); + else if (strcasecmp(str, "tab") == 0) + res = sexp_make_character('\t'); + else { + res = sexp_read_error("unknown character name", + sexp_list1(sexp_c_string(str)), + in); + } + } + sexp_free(str); + break; + case '(': + sexp_push_char(c1, in); + res = sexp_read(in); + if (sexp_listp(res) == SEXP_FALSE) { + if (! sexp_exceptionp(res)) { + sexp_deep_free(res); + res = sexp_read_error("dotted list not allowed in vector syntax", + SEXP_NULL, + in); + } + } else { + res = sexp_list_to_vector(res); + } + break; + default: + res = 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 == '-') { +#ifdef USE_FLONUMS + if (sexp_flonump(res)) + sexp_flonum_value(res) = -1 * sexp_flonum_value(res); + else +#endif + 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; +} + +#if USE_STRING_STREAMS +sexp sexp_read_from_string(char *str) { + sexp s = sexp_c_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; +} +#endif + +void sexp_init() { + int i; + if (! sexp_initialized_p) { + sexp_initialized_p = 1; +#if USE_BOEHM + GC_init(); + GC_add_roots((char*)&symbol_table, + ((char*)&symbol_table)+sizeof(symbol_table)+1); +#endif + for (i=0; i +#include +#include +#include +#include +#include +#include +#include + +/* tagging system + * bits end in 00: pointer + * 01: fixnum + * 011: + * 111: immediate symbol + * 0110: char + * 1110: other immediate object (NULL, TRUE, FALSE) + */ + +#define SEXP_FIXNUM_BITS 2 +#define SEXP_IMMEDIATE_BITS 3 +#define SEXP_EXTENDED_BITS 4 + +#define SEXP_FIXNUM_MASK 3 +#define SEXP_IMMEDIATE_MASK 7 +#define SEXP_EXTENDED_MASK 15 + +#define SEXP_POINTER_TAG 0 +#define SEXP_FIXNUM_TAG 1 +#define SEXP_ISYMBOL_TAG 7 +#define SEXP_CHAR_TAG 6 +#define SEXP_EXTENDED_TAG 14 + +#define SEXP_MAX_INT ((1<<29)-1) +#define SEXP_MIN_INT (-(1<<29)) + +enum sexp_types { + SEXP_OBJECT, + SEXP_FIXNUM, + SEXP_CHAR, + SEXP_BOOLEAN, + SEXP_PAIR, + SEXP_SYMBOL, + SEXP_STRING, + SEXP_VECTOR, + SEXP_FLONUM, + SEXP_BIGNUM, + SEXP_IPORT, + SEXP_OPORT, + SEXP_EXCEPTION, + /* the following are used only by the evaluator */ + SEXP_PROCEDURE, + SEXP_MACRO, + SEXP_SYNCLO, + SEXP_ENV, + SEXP_BYTECODE, + SEXP_CORE, + SEXP_OPCODE, + SEXP_LAMBDA, + SEXP_CND, + SEXP_REF, + SEXP_SET, + SEXP_SEQ, + SEXP_LIT, + SEXP_CONTEXT, +}; + +typedef unsigned long sexp_uint_t; +typedef long sexp_sint_t; +typedef char sexp_tag_t; +typedef struct sexp_struct *sexp; + +struct sexp_struct { + sexp_tag_t tag; + union { + /* basic types */ + double flonum; + struct { + sexp car, cdr; + } pair; + struct { + sexp_uint_t length; + sexp *data; + } vector; + struct { + sexp_uint_t length; + char *data; + } string; + struct { + sexp_uint_t length; + char *data; + } symbol; + struct { + FILE *stream; + char *name; + sexp_uint_t line; + sexp cookie; + } port; + struct { + sexp kind, message, irritants, procedure, file, line; + } exception; + /* runtime types */ + struct { + char flags; + sexp parent, lambda, bindings; + } env; + struct { + sexp_uint_t length; + sexp name, literals; + unsigned char data[]; + } bytecode; + struct { + char flags; + unsigned short num_args; + sexp bc, vars; + } procedure; + struct { + sexp proc, env; + } macro; + struct { + sexp env, free_vars, expr; + } synclo; + struct { + unsigned char op_class, code, num_args, flags, + arg1_type, arg2_type, inverse; + char *name; + sexp dflt, data, proc; + } opcode; + struct { + char code; + char *name; + } core; + /* ast types */ + struct { + sexp name, params, locals, defs, flags, body, fv, sv; + } lambda; + struct { + sexp test, pass, fail; + } cnd; + struct { + sexp var, value; + } set; + struct { + sexp name, cell; + } ref; + struct { + sexp ls; + } seq; + struct { + sexp value; + } lit; + /* compiler state */ + struct { + sexp bc, lambda, *stack, env, fv; + sexp_uint_t pos, top, depth, tailp, tracep; + } context; + } value; +}; + +#define sexp_sizeof(x) (offsetof(struct sexp_struct, value) \ + + sizeof(((sexp)0)->value.x)) + +#define sexp_alloc_type(type, tag) sexp_alloc_tagged(sexp_sizeof(type), tag) + +#define SEXP_MAKE_IMMEDIATE(n) ((sexp) ((n<tag) + +#define sexp_check_tag(x,t) (sexp_pointerp(x) && (sexp_pointer_tag(x) == (t))) + +#define sexp_pairp(x) (sexp_check_tag(x, SEXP_PAIR)) +#define sexp_stringp(x) (sexp_check_tag(x, SEXP_STRING)) +#define sexp_lsymbolp(x) (sexp_check_tag(x, SEXP_SYMBOL)) +#define sexp_vectorp(x) (sexp_check_tag(x, SEXP_VECTOR)) +#define sexp_flonump(x) (sexp_check_tag(x, SEXP_FLONUM)) +#define sexp_iportp(x) (sexp_check_tag(x, SEXP_IPORT)) +#define sexp_oportp(x) (sexp_check_tag(x, SEXP_OPORT)) +#define sexp_exceptionp(x) (sexp_check_tag(x, SEXP_EXCEPTION)) +#define sexp_procedurep(x) (sexp_check_tag(x, SEXP_PROCEDURE)) +#define sexp_envp(x) (sexp_check_tag(x, SEXP_ENV)) +#define sexp_bytecodep(x) (sexp_check_tag(x, SEXP_BYTECODE)) +#define sexp_corep(x) (sexp_check_tag(x, SEXP_CORE)) +#define sexp_opcodep(x) (sexp_check_tag(x, SEXP_OPCODE)) +#define sexp_macrop(x) (sexp_check_tag(x, SEXP_MACRO)) +#define sexp_synclop(x) (sexp_check_tag(x, SEXP_SYNCLO)) +#define sexp_lambdap(x) (sexp_check_tag(x, SEXP_LAMBDA)) +#define sexp_cndp(x) (sexp_check_tag(x, SEXP_CND)) +#define sexp_refp(x) (sexp_check_tag(x, SEXP_REF)) +#define sexp_setp(x) (sexp_check_tag(x, SEXP_SET)) +#define sexp_seqp(x) (sexp_check_tag(x, SEXP_SEQ)) +#define sexp_litp(x) (sexp_check_tag(x, SEXP_LIT)) +#define sexp_symbolp(x) (sexp_isymbolp(x) || sexp_lsymbolp(x)) + +/***************************** constructors ****************************/ + +#define sexp_make_boolean(x) ((x) ? SEXP_TRUE : SEXP_FALSE) +#define sexp_unbox_boolean(x) (((x) == SEXP_FALSE) ? 0 : 1) + +#define sexp_make_integer(n) ((sexp) ((((sexp_sint_t)n)<>SEXP_FIXNUM_BITS) + +#define sexp_make_character(n) ((sexp) ((((sexp_sint_t)n)<>SEXP_EXTENDED_BITS)) + +#define sexp_flonum_value(f) ((f)->value.flonum) + +#if USE_FLONUMS +#define sexp_integer_to_flonum(x) (sexp_make_flonum(sexp_unbox_integer(x))) +#else +#define sexp_integer_to_flonum(x) (x) +#endif + +/*************************** field accessors **************************/ + +#define sexp_vector_length(x) ((x)->value.vector.length) +#define sexp_vector_data(x) ((x)->value.vector.data) + +#define sexp_vector_ref(x,i) (sexp_vector_data(x)[sexp_unbox_integer(i)]) +#define sexp_vector_set(x,i,v) (sexp_vector_data(x)[sexp_unbox_integer(i)]=(v)) + +#define sexp_procedure_num_args(x) ((x)->value.procedure.num_args) +#define sexp_procedure_flags(x) ((x)->value.procedure.flags) +#define sexp_procedure_variadic_p(x) (sexp_unbox_integer(sexp_procedure_flags(x)) & 1) +#define sexp_procedure_code(x) ((x)->value.procedure.bc) +#define sexp_procedure_vars(x) ((x)->value.procedure.vars) + +#define sexp_string_length(x) ((x)->value.string.length) +#define sexp_string_data(x) ((x)->value.string.data) + +#define sexp_string_ref(x, i) (sexp_make_character(sexp_string_data(x)[sexp_unbox_integer(i)])) +#define sexp_string_set(x, i, v) (sexp_string_data(x)[sexp_unbox_integer(i)] = sexp_unbox_character(v)) + +#define sexp_symbol_length(x) ((x)->value.symbol.length) +#define sexp_symbol_data(x) ((x)->value.symbol.data) + +#define sexp_port_stream(p) ((p)->value.port.stream) +#define sexp_port_name(p) ((p)->value.port.name) +#define sexp_port_line(p) ((p)->value.port.line) +#define sexp_port_cookie(p) ((p)->value.port.cookie) + +#define sexp_exception_kind(p) ((p)->value.exception.kind) +#define sexp_exception_message(p) ((p)->value.exception.message) +#define sexp_exception_irritants(p) ((p)->value.exception.irritants) +#define sexp_exception_procedure(p) ((p)->value.exception.procedure) +#define sexp_exception_file(p) ((p)->value.exception.file) +#define sexp_exception_line(p) ((p)->value.exception.line) + +#define sexp_bytecode_length(x) ((x)->value.bytecode.length) +#define sexp_bytecode_name(x) ((x)->value.bytecode.name) +#define sexp_bytecode_literals(x) ((x)->value.bytecode.literals) +#define sexp_bytecode_data(x) ((x)->value.bytecode.data) + +#define sexp_env_flags(x) ((x)->value.env.flags) +#define sexp_env_parent(x) ((x)->value.env.parent) +#define sexp_env_bindings(x) ((x)->value.env.bindings) +#define sexp_env_local_p(x) (sexp_env_parent(x)) +#define sexp_env_global_p(x) (! sexp_env_local_p(x)) +#define sexp_env_lambda(x) ((x)->value.env.lambda) + +#define sexp_macro_proc(x) ((x)->value.macro.proc) +#define sexp_macro_env(x) ((x)->value.macro.env) + +#define sexp_synclo_env(x) ((x)->value.synclo.env) +#define sexp_synclo_free_vars(x) ((x)->value.synclo.free_vars) +#define sexp_synclo_expr(x) ((x)->value.synclo.expr) + +#define sexp_core_code(x) ((x)->value.core.code) +#define sexp_core_name(x) ((x)->value.core.name) + +#define sexp_opcode_class(x) ((x)->value.opcode.op_class) +#define sexp_opcode_code(x) ((x)->value.opcode.code) +#define sexp_opcode_num_args(x) ((x)->value.opcode.num_args) +#define sexp_opcode_flags(x) ((x)->value.opcode.flags) +#define sexp_opcode_arg1_type(x) ((x)->value.opcode.arg1_type) +#define sexp_opcode_arg2_type(x) ((x)->value.opcode.arg2_type) +#define sexp_opcode_inverse(x) ((x)->value.opcode.inverse) +#define sexp_opcode_name(x) ((x)->value.opcode.name) +#define sexp_opcode_default(x) ((x)->value.opcode.dflt) +#define sexp_opcode_data(x) ((x)->value.opcode.data) +#define sexp_opcode_proc(x) ((x)->value.opcode.proc) + +#define sexp_opcode_variadic_p(x) (sexp_opcode_flags(x) & 1) +#define sexp_opcode_opt_param_p(x) (sexp_opcode_flags(x) & 2) + +#define sexp_lambda_name(x) ((x)->value.lambda.name) +#define sexp_lambda_params(x) ((x)->value.lambda.params) +#define sexp_lambda_locals(x) ((x)->value.lambda.locals) +#define sexp_lambda_defs(x) ((x)->value.lambda.defs) +#define sexp_lambda_flags(x) ((x)->value.lambda.flags) +#define sexp_lambda_body(x) ((x)->value.lambda.body) +#define sexp_lambda_fv(x) ((x)->value.lambda.fv) +#define sexp_lambda_sv(x) ((x)->value.lambda.sv) + +#define sexp_cnd_test(x) ((x)->value.cnd.test) +#define sexp_cnd_pass(x) ((x)->value.cnd.pass) +#define sexp_cnd_fail(x) ((x)->value.cnd.fail) + +#define sexp_set_var(x) ((x)->value.set.var) +#define sexp_set_value(x) ((x)->value.set.value) + +#define sexp_ref_name(x) ((x)->value.ref.name) +#define sexp_ref_cell(x) ((x)->value.ref.cell) +#define sexp_ref_loc(x) (sexp_cdr(sexp_ref_cell(x))) + +#define sexp_seq_ls(x) ((x)->value.seq.ls) + +#define sexp_lit_value(x) ((x)->value.lit.value) + +#define sexp_context_env(x) ((x)->value.context.env) +#define sexp_context_stack(x) ((x)->value.context.stack) +#define sexp_context_depth(x) ((x)->value.context.depth) +#define sexp_context_bc(x) ((x)->value.context.bc) +#define sexp_context_fv(x) ((x)->value.context.fv) +#define sexp_context_pos(x) ((x)->value.context.pos) +#define sexp_context_top(x) ((x)->value.context.top) +#define sexp_context_lambda(x) ((x)->value.context.lambda) +#define sexp_context_tailp(x) ((x)->value.context.tailp) +#define sexp_context_tracep(x) ((x)->value.context.tailp) + +/****************************** arithmetic ****************************/ + +#define sexp_fx_add(a, b) ((sexp)(((sexp_sint_t)a)+((sexp_sint_t)b)-SEXP_FIXNUM_TAG)) +#define sexp_fx_sub(a, b) ((sexp)(((sexp_sint_t)a)-((sexp_sint_t)b)+SEXP_FIXNUM_TAG)) +#define sexp_fx_mul(a, b) ((sexp)((((((sexp_sint_t)a)-SEXP_FIXNUM_TAG)*(((sexp_sint_t)b)>>SEXP_FIXNUM_BITS))+SEXP_FIXNUM_TAG))) +#define sexp_fx_div(a, b) (sexp_make_integer(sexp_unbox_integer(a) / sexp_unbox_integer(b))) +#define sexp_fx_rem(a, b) (sexp_make_integer(sexp_unbox_integer(a) % sexp_unbox_integer(b))) +#define sexp_fx_sign(a) (-((sexp_sint_t)(a) < 0)) /* -1 or 0 */ + +#define sexp_fp_add(a, b) (sexp_make_flonum(sexp_flonum_value(a) + sexp_flonum_value(b))) +#define sexp_fp_sub(a, b) (sexp_make_flonum(sexp_flonum_value(a) - sexp_flonum_value(b))) +#define sexp_fp_mul(a, b) (sexp_make_flonum(sexp_flonum_value(a) * sexp_flonum_value(b))) +#define sexp_fp_div(a, b) (sexp_make_flonum(sexp_flonum_value(a) / sexp_flonum_value(b))) + +/****************************** utilities *****************************/ + +#define sexp_list1(a) sexp_cons(a, SEXP_NULL) +#define sexp_list2(a, b) sexp_cons(a, sexp_cons(b, SEXP_NULL)) +#define sexp_list3(a, b, c) sexp_cons(a, sexp_cons(b, sexp_cons(c, SEXP_NULL))) +#define sexp_list4(a, b, c, d) sexp_cons(a, sexp_cons(b, sexp_cons(c, sexp_cons(d, SEXP_NULL)))) + +#define sexp_push(ls, x) ((ls) = sexp_cons((x), (ls))) +#define sexp_insert(ls, x) ((sexp_memq((x), (ls)) != SEXP_FALSE) ? (ls) : sexp_push((ls), (x))) + +#define sexp_car(x) ((x)->value.pair.car) +#define sexp_cdr(x) ((x)->value.pair.cdr) + +#define sexp_caar(x) (sexp_car(sexp_car(x))) +#define sexp_cadr(x) (sexp_car(sexp_cdr(x))) +#define sexp_cdar(x) (sexp_cdr(sexp_car(x))) +#define sexp_cddr(x) (sexp_cdr(sexp_cdr(x))) +#define sexp_caaar(x) (sexp_car(sexp_caar(x))) +#define sexp_caadr(x) (sexp_car(sexp_cadr(x))) +#define sexp_cadar(x) (sexp_car(sexp_cdar(x))) +#define sexp_caddr(x) (sexp_car(sexp_cddr(x))) +#define sexp_cdaar(x) (sexp_cdr(sexp_caar(x))) +#define sexp_cdadr(x) (sexp_cdr(sexp_cadr(x))) +#define sexp_cddar(x) (sexp_cdr(sexp_cdar(x))) +#define sexp_cdddr(x) (sexp_cdr(sexp_cddr(x))) +#define sexp_cadddr(x) (sexp_cadr(sexp_cddr(x))) +#define sexp_cddddr(x) (sexp_cddr(sexp_cddr(x))) + +/***************************** general API ****************************/ + +#define sexp_read_char(p) (getc(sexp_port_stream(p))) +#define sexp_push_char(c, p) (ungetc(c, sexp_port_stream(p))) +#define sexp_write_char(c, p) (putc(c, sexp_port_stream(p))) +#define sexp_write_string(s, p) (fputs(s, sexp_port_stream(p))) +#define sexp_printf(p, ...) (fprintf(sexp_port_stream(p), __VA_ARGS__)) +#define sexp_scanf(p, ...) (fscanf(sexp_port_stream(p), __VA_ARGS__)) +#define sexp_flush(p) (fflush(sexp_port_stream(p))) + +sexp sexp_alloc_tagged(size_t size, sexp_uint_t tag); +sexp sexp_cons(sexp head, sexp tail); +sexp sexp_equalp (sexp a, sexp b); +sexp sexp_listp(sexp obj); +sexp sexp_reverse(sexp ls); +sexp sexp_nreverse(sexp ls); +sexp sexp_append(sexp a, sexp b); +sexp sexp_memq(sexp x, sexp ls); +sexp sexp_assq(sexp x, sexp ls); +sexp sexp_length(sexp ls); +sexp sexp_c_string(char *str); +sexp sexp_make_string(sexp len, sexp ch); +sexp sexp_substring (sexp str, sexp start, sexp end); +sexp sexp_make_flonum(double f); +sexp_uint_t sexp_string_hash(char *str, sexp_uint_t acc); +sexp sexp_intern(char *str); +sexp sexp_string_to_symbol(sexp str); +sexp sexp_make_vector(sexp len, sexp dflt); +sexp sexp_list_to_vector(sexp ls); +sexp sexp_vector(int count, ...); +void sexp_write(sexp obj, sexp out); +char* sexp_read_string(sexp in); +char* sexp_read_symbol(sexp in, int init); +sexp sexp_read_number(sexp in, int base); +sexp sexp_read_raw(sexp in); +sexp sexp_read(sexp in); +sexp sexp_read_from_string(char *str); +sexp sexp_make_input_port(FILE* in, char *path); +sexp sexp_make_output_port(FILE* out, char *path); +sexp sexp_make_input_string_port(sexp str); +sexp sexp_make_output_string_port(); +sexp sexp_get_output_string(sexp port); +sexp sexp_make_exception(sexp kind, sexp message, sexp irritants, sexp procedure, sexp file, sexp line); +sexp sexp_user_exception (sexp self, char *message, sexp obj); +sexp sexp_type_exception (char *message, sexp obj); +sexp sexp_range_exception (sexp obj, sexp start, sexp end); +sexp sexp_print_exception(sexp exn, sexp out); +void sexp_init(); + +#endif /* ! SEXP_H */ + diff --git a/syntax-rules.scm b/syntax-rules.scm new file mode 100644 index 00000000..468c4bdf --- /dev/null +++ b/syntax-rules.scm @@ -0,0 +1,182 @@ + +(define-syntax syntax-rules + (er-macro-transformer + (lambda (expr rename compare) + (let ((lits (cadr expr)) + (forms (cddr expr)) + (count 0) + (_er-macro-transformer (rename 'er-macro-transformer)) + (_lambda (rename 'lambda)) (_let (rename 'let)) + (_begin (rename 'begin)) (_if (rename 'if)) + (_and (rename 'and)) (_or (rename 'or)) + (_eq? (rename 'eq?)) (_equal? (rename 'equal?)) + (_car (rename 'car)) (_cdr (rename 'cdr)) + (_cons (rename 'cons)) (_pair? (rename 'pair?)) + (_null? (rename 'null?)) (_expr (rename 'expr)) + (_rename (rename 'rename)) (_compare (rename 'compare)) + (_quote (rename 'quote)) (_apply (rename 'apply)) + (_append (rename 'append)) (_map (rename 'map)) + (_vector? (rename 'vector?)) (_list? (rename 'list?)) + (_lp (rename 'lp)) (_reverse (rename 'reverse)) + (_vector->list (rename 'vector->list)) + (_list->vector (rename 'list->vector))) + (define (next-v) + (set! count (+ count 1)) + (rename (string->symbol (string-append "v." (number->string count))))) + (define (expand-pattern pat tmpl) + (let lp ((p (cdr pat)) + (x (list _cdr _expr)) + (dim 0) + (vars '()) + (k (lambda (vars) + (or (expand-template tmpl vars) + (list _begin #f))))) + (let ((v (next-v))) + (list + _let (list (list v x)) + (cond + ((identifier? p) + (if (any (lambda (l) (compare p l)) lits) + (list _and (list _compare v (list _quote p)) (k vars)) + (list _let (list (list p v)) (k (cons (cons p dim) vars))))) + ((ellipse? p) + (cond + ((not (null? (cddr p))) + (error "non-trailing ellipse")) + ((identifier? (car p)) + (list _and (list _list? v) + (list _let (list (list (car p) v)) + (k (cons (cons (car p) (+ 1 dim)) vars))))) + (else + (let* ((w (next-v)) + (new-vars (all-vars (car p) (+ dim 1))) + (ls-vars (map (lambda (x) + (rename + (string->symbol + (string-append + (symbol->string + (identifier->symbol (car x))) + "-ls")))) + new-vars)) + (once + (lp (car p) (list _car w) (+ dim 1) '() + (lambda (_) + (cons + _lp + (cons + (list _cdr w) + (map (lambda (x l) + (list _cons (car x) l)) + new-vars + ls-vars))))))) + (list + _let + _lp (cons (list w v) + (map (lambda (x) (list x '())) ls-vars)) + (list _if (list _null? w) + (list _let (map (lambda (x l) + (list (car x) (list _reverse l))) + new-vars + ls-vars) + (k (append new-vars vars))) + (list _and (list _pair? w) once))))))) + ((pair? p) + (list _and (list _pair? v) + (lp (car p) + (list _car v) + dim + vars + (lambda (vars) + (lp (cdr p) (list _cdr v) dim vars k))))) + ((vector? p) + (list _and + (list _vector? v) + (lp (vector->list p) (list _vector->list v) dim vars k))) + ((null? p) (list _and (list _null? v) (k vars))) + (else (list _and (list _equal? v p) (k vars)))))))) + (define (ellipse? x) + (and (pair? x) (pair? (cdr x)) (compare '... (cadr x)))) + (define (ellipse-depth x) + (if (ellipse? x) + (+ 1 (ellipse-depth (cdr x))) + 0)) + (define (ellipse-tail x) + (if (ellipse? x) + (ellipse-tail (cdr x)) + (cdr x))) + (define (all-vars x dim) + (let lp ((x x) (dim dim) (vars '())) + (cond ((identifier? x) (if (memq x (list _quote lits)) + vars + (cons (cons x dim) vars))) + ((ellipse? x) (lp (car x) (+ dim 1) vars)) + ((pair? x) (lp (car x) dim (lp (cdr x) dim vars))) + ((vector? x) (lp (vector->list x) dim vars)) + (else vars)))) + (define (free-vars x vars dim) + (let lp ((x x) (free '())) + (cond + ((identifier? x) + (if (and (not (memq x free)) + (cond ((assq x vars) => (lambda (cell) (>= (cdr cell) dim))) + (else #f))) + (cons x free) + free)) + ((pair? x) (lp (car x) (lp (cdr x) free))) + ((vector? x) (lp (vector->list x) free)) + (else free)))) + (define (expand-template tmpl vars) + (let lp ((t tmpl) (dim 0)) + (cond + ((identifier? t) + (cond + ((assq t vars) + => (lambda (cell) + (if (<= (cdr cell) dim) + t + (error "too few ...'s")))) + (else + (list _rename (list _quote t))))) + ((pair? t) + (if (ellipse? t) + (let* ((depth (ellipse-depth t)) + (ell-dim (+ dim depth)) + (ell-vars (free-vars (car t) vars ell-dim))) + (if (null? ell-vars) + (error "too many ...'s") + (let* ((once (lp (car t) ell-dim)) + (nest (if (and (null? (cdr ell-vars)) + (identifier? once) + (eq? once (car vars))) + once ;; shortcut + (cons _map + (cons (list _lambda ell-vars once) + ell-vars)))) + (many (do ((d depth (- d 1)) + (many nest + (list _apply _append many))) + ((= d 1) many)))) + (if (null? (ellipse-tail t)) + many ;; shortcut + (list _append many (lp (ellipse-tail t) dim)))))) + (list _cons (lp (car t) dim) (lp (cdr t) dim)))) + ((vector? t) (list _list->vector (lp (vector->list t) dim))) + ((null? t) (list _quote '())) + (else t)))) + (list + _er-macro-transformer + (list _lambda (list _expr _rename _compare) + (cons + _or + (append + (map + (lambda (clause) (expand-pattern (car clause) (cadr clause))) + forms) + (list (list 'error "no expansion")))))))))) + +;; Local Variables: +;; eval: (put '_lambda 'scheme-indent-function 1) +;; eval: (put '_let 'scheme-indent-function 'scheme-let-indent) +;; eval: (put '_if 'scheme-indent-function 3) +;; End: + diff --git a/tests/basic/test00-fact-3.res b/tests/basic/test00-fact-3.res new file mode 100644 index 00000000..f76d3d1e --- /dev/null +++ b/tests/basic/test00-fact-3.res @@ -0,0 +1 @@ +(fact 3) => 6 diff --git a/tests/basic/test00-fact-3.scm b/tests/basic/test00-fact-3.scm new file mode 100644 index 00000000..41d9c20e --- /dev/null +++ b/tests/basic/test00-fact-3.scm @@ -0,0 +1,14 @@ + +(define (fact-helper x res) + (if (= x 0) + res + (fact-helper (- x 1) (* res x)))) + +(define (fact x) + (fact-helper x 1)) + +(display "(fact 3) => ") +(write (fact 3)) +(newline) + + diff --git a/tests/basic/test01-apply.res b/tests/basic/test01-apply.res new file mode 100644 index 00000000..c5b83af4 --- /dev/null +++ b/tests/basic/test01-apply.res @@ -0,0 +1,8 @@ +11 +(11 10 9 8 7 6 5 4 3 2 1) +(1 2 3 4) +100 +100 +100 +100 +100 diff --git a/tests/basic/test01-apply.scm b/tests/basic/test01-apply.scm new file mode 100644 index 00000000..183a591c --- /dev/null +++ b/tests/basic/test01-apply.scm @@ -0,0 +1,18 @@ + +(define foo + (lambda (a b c d e f g h) + (+ (+ (* a b) (* c d)) (+ (* e f) (* g h))))) + +(define (writeln x) + (write x) + (newline)) + +(writeln (length (reverse (list 1 2 3 4 5 6 7 8 9 10 11)))) +(writeln (reverse (list 1 2 3 4 5 6 7 8 9 10 11))) +(writeln (append (list 1 2) (list 3 4))) +(writeln (foo 1 2 3 4 5 6 7 8)) +(writeln (apply foo (list 1 2 3 4 5 6 7 8))) +(writeln (apply foo 1 (list 2 3 4 5 6 7 8))) +(writeln (apply foo 1 2 3 4 (list 5 6 7 8))) +(writeln (apply foo 1 2 3 4 5 (list 6 7 8))) + diff --git a/tests/basic/test02-closure.res b/tests/basic/test02-closure.res new file mode 100644 index 00000000..4d764d20 --- /dev/null +++ b/tests/basic/test02-closure.res @@ -0,0 +1,6 @@ +1 +2 +101 +102 +3 +103 diff --git a/tests/basic/test02-closure.scm b/tests/basic/test02-closure.scm new file mode 100644 index 00000000..6ed987fe --- /dev/null +++ b/tests/basic/test02-closure.scm @@ -0,0 +1,16 @@ + +(define (make-counter n) + (lambda () + (set! n (+ n 1)) + n)) + +(define f (make-counter 0)) +(define g (make-counter 100)) + +(write (f)) (newline) +(write (f)) (newline) +(write (g)) (newline) +(write (g)) (newline) +(write (f)) (newline) +(write (g)) (newline) + diff --git a/tests/basic/test03-nested-closure.res b/tests/basic/test03-nested-closure.res new file mode 100644 index 00000000..c97c8394 --- /dev/null +++ b/tests/basic/test03-nested-closure.res @@ -0,0 +1 @@ +11357 diff --git a/tests/basic/test03-nested-closure.scm b/tests/basic/test03-nested-closure.scm new file mode 100644 index 00000000..6656bd4e --- /dev/null +++ b/tests/basic/test03-nested-closure.scm @@ -0,0 +1,8 @@ + +((lambda (a b) + ((lambda (c d e) + (write (+ e (* c 1000) (* a 100) (* b 10) d)) + (newline)) + (- a 2) (+ b 2) 10000)) + 3 5) + diff --git a/tests/basic/test04-nested-let.res b/tests/basic/test04-nested-let.res new file mode 100644 index 00000000..c97c8394 --- /dev/null +++ b/tests/basic/test04-nested-let.res @@ -0,0 +1 @@ +11357 diff --git a/tests/basic/test04-nested-let.scm b/tests/basic/test04-nested-let.scm new file mode 100644 index 00000000..584bc6e5 --- /dev/null +++ b/tests/basic/test04-nested-let.scm @@ -0,0 +1,9 @@ + +(let ((a 3) + (b 5)) + (let ((c (- a 2)) + (d (+ b 2)) + (e 10000)) + (write (+ e (* c 1000) (* a 100) (* b 10) d)) + (newline))) + diff --git a/tests/basic/test05-internal-define.res b/tests/basic/test05-internal-define.res new file mode 100644 index 00000000..4edae4cc --- /dev/null +++ b/tests/basic/test05-internal-define.res @@ -0,0 +1 @@ +1000 1003 diff --git a/tests/basic/test05-internal-define.scm b/tests/basic/test05-internal-define.scm new file mode 100644 index 00000000..a5576a63 --- /dev/null +++ b/tests/basic/test05-internal-define.scm @@ -0,0 +1,8 @@ + +(let ((a 1000)) + (define b (+ a 3)) + (write a) + (display " ") + (write b) + (newline)) + diff --git a/tests/basic/test06-letrec.res b/tests/basic/test06-letrec.res new file mode 100644 index 00000000..83d9c566 --- /dev/null +++ b/tests/basic/test06-letrec.res @@ -0,0 +1,4 @@ +7 +#t +#f +#f diff --git a/tests/basic/test06-letrec.scm b/tests/basic/test06-letrec.scm new file mode 100644 index 00000000..a9c01b4e --- /dev/null +++ b/tests/basic/test06-letrec.scm @@ -0,0 +1,15 @@ + +(letrec ((add (lambda (a b) (+ a b)))) + (write (add 3 4)) + (newline)) + +(letrec ((even? (lambda (n) (if (zero? n) #t (odd? (- n 1))))) + (odd? (lambda (n) (if (zero? n) #f (even? (- n 1)))))) + (write (even? 1000)) + (newline) + (write (even? 1001)) + (newline) + (write (odd? 1000)) + (newline) + ) + diff --git a/tests/basic/test07-mutation.res b/tests/basic/test07-mutation.res new file mode 100644 index 00000000..c97c8394 --- /dev/null +++ b/tests/basic/test07-mutation.res @@ -0,0 +1 @@ +11357 diff --git a/tests/basic/test07-mutation.scm b/tests/basic/test07-mutation.scm new file mode 100644 index 00000000..8dacb7fb --- /dev/null +++ b/tests/basic/test07-mutation.scm @@ -0,0 +1,9 @@ + +(let ((a 3) + (b 5)) + (let ((c (- a 2)) + (d (+ b 2)) + (e #f)) + (set! e 10000) + (write (+ e (* c 1000) (* a 100) (* b 10) d)) + (newline))) diff --git a/tests/basic/test08-callcc.res b/tests/basic/test08-callcc.res new file mode 100644 index 00000000..849baeed --- /dev/null +++ b/tests/basic/test08-callcc.res @@ -0,0 +1 @@ +543 diff --git a/tests/basic/test08-callcc.scm b/tests/basic/test08-callcc.scm new file mode 100644 index 00000000..3a5c355e --- /dev/null +++ b/tests/basic/test08-callcc.scm @@ -0,0 +1,34 @@ + +(define fail + (lambda () 999999)) + +(define in-range + (lambda (a b) + (call-with-current-continuation + (lambda (cont) + (enumerate a b cont))))) + +(define enumerate + (lambda (a b cont) + (if (< b a) + (fail) + (let ((save fail)) + (begin + (set! fail + (lambda () + (begin + (set! fail save) + (enumerate (+ a 1) b cont)))) + (cont a)))))) + +(write + (let ((x (in-range 2 9)) + (y (in-range 2 9)) + (z (in-range 2 9))) + (if (= (* x x) + (+ (* y y) (* z z))) + (+ (* x 100) (+ (* y 10) z)) + (fail)))) + +(newline) + diff --git a/tests/basic/test09-hygiene.res b/tests/basic/test09-hygiene.res new file mode 100644 index 00000000..8a1218a1 --- /dev/null +++ b/tests/basic/test09-hygiene.res @@ -0,0 +1,5 @@ +1 +2 +3 +4 +5 diff --git a/tests/basic/test09-hygiene.scm b/tests/basic/test09-hygiene.scm new file mode 100644 index 00000000..c3f0bb7e --- /dev/null +++ b/tests/basic/test09-hygiene.scm @@ -0,0 +1,25 @@ + +(write (or 1)) +(newline) +(write (or #f 2)) +(newline) +(write (or 3 #t)) +(newline) + +(let ((tmp 4)) + (write (or #f tmp)) + (newline)) + +(write + (letrec-syntax + ((myor + (er-macro-transformer + (lambda (expr rename compare) + (if (null? (cdr expr)) + #f + (list (rename 'let) (list (list (rename 'tmp) (cadr expr))) + (list (rename 'if) (rename 'tmp) + (rename 'tmp) + (cons (rename 'myor) (cddr expr))))))))) + (let ((tmp 5)) (myor #f tmp)))) +(newline) diff --git a/tests/basic/test10-unhygiene.res b/tests/basic/test10-unhygiene.res new file mode 100644 index 00000000..0d174dc4 --- /dev/null +++ b/tests/basic/test10-unhygiene.res @@ -0,0 +1,6 @@ +1 +1 +1 +6 +7 +8 diff --git a/tests/basic/test10-unhygiene.scm b/tests/basic/test10-unhygiene.scm new file mode 100644 index 00000000..c60a6bca --- /dev/null +++ b/tests/basic/test10-unhygiene.scm @@ -0,0 +1,49 @@ + +(define-syntax aif + (sc-macro-transformer + (lambda (form environment) + (let ((condition + (make-syntactic-closure environment '() (cadr form))) + (consequent + (make-syntactic-closure environment '(it) (caddr form))) + (alternative + (make-syntactic-closure environment '() (cadddr form)))) + `(let ((it ,condition)) + (if it + ,consequent + ,alternative)))))) + +(write (aif 1 it 3)) +(newline) + +(write (let ((it 4)) (aif 1 it 3))) +(newline) + +(write (let ((it 4)) (aif (let ((it 5)) 1) it 3))) +(newline) + +(write (let ((it 4)) (aif (let ((it 5)) 1) (let ((it 6)) it) 3))) +(newline) + +(write + (letrec-syntax + ((myor + (er-macro-transformer + (lambda (expr rename compare) + (if (null? (cdr expr)) + #f + (list (rename 'let) (list (list (rename 'it) (cadr expr))) + (list (rename 'if) (rename 'it) + (rename 'it) + (cons (rename 'myor) (cddr expr))))))))) + (let ((it 7)) (myor #f it)))) +(newline) + +(define-syntax define-foo + (sc-macro-transformer + (lambda (form environment) + (make-syntactic-closure environment '(foo) `(define foo 8))))) + +(define-foo) +(write foo) +(newline) diff --git a/tests/r5rs-tests.scm b/tests/r5rs-tests.scm new file mode 100644 index 00000000..e11ced4c --- /dev/null +++ b/tests/r5rs-tests.scm @@ -0,0 +1,373 @@ + +(define *tests-run* 0) +(define *tests-passed* 0) + +(define-syntax test + (syntax-rules () + ((test expect expr) + (begin + (set! *tests-run* (+ *tests-run* 1)) + (let ((str (call-with-output-string (lambda (out) (display 'expr out)))) + (res expr)) + (display str) + (write-char #\space) + (display (make-string (max 0 (- 72 (string-length str))) #\.)) + (flush-output) + (cond + ((equal? res expect) + (set! *tests-passed* (+ *tests-passed* 1)) + (display " [PASS]\n")) + (else + (display " [FAIL]\n") + (display " expected ") (write expect) + (display " but got ") (write res) (newline)))))))) + +(define (test-report) + (write *tests-passed*) + (display " out of ") + (write *tests-run*) + (display " passed (") + (write (* (/ *tests-passed* *tests-run*) 100)) + (display "%)") + (newline)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(test 8 ((lambda (x) (+ x x)) 4)) + +(test '(3 4 5 6) ((lambda x x) 3 4 5 6)) + +(test '(5 6) ((lambda (x y . z) z) 3 4 5 6)) + +(test 'yes (if (> 3 2) 'yes 'no)) + +(test 'no (if (> 2 3) 'yes 'no)) + +(test 1 (if (> 3 2) (- 3 2) (+ 3 2))) + +(test 'greater (cond ((> 3 2) 'greater) ((< 3 2) 'less))) + +(test 'equal (cond ((> 3 3) 'greater) ((< 3 3) 'less) (else 'equal))) + +(test 'composite (case (* 2 3) ((2 3 5 7) 'prime) ((1 4 6 8 9) 'composite))) + +(test 'consonant + (case (car '(c d)) + ((a e i o u) 'vowel) + ((w y) 'semivowel) + (else 'consonant))) + +(test #t (and (= 2 2) (> 2 1))) + +(test #f (and (= 2 2) (< 2 1))) + +(test '(f g) (and 1 2 'c '(f g))) + +(test #t (and)) + +(test #t (or (= 2 2) (> 2 1))) + +(test #t (or (= 2 2) (< 2 1))) + +(test '(b c) (or (memq 'b '(a b c)) (/ 3 0))) + +(test 6 (let ((x 2) (y 3)) (* x y))) + +(test 35 (let ((x 2) (y 3)) (let ((x 7) (z (+ x y))) (* z x)))) + +(test 70 (let ((x 2) (y 3)) (let* ((x 7) (z (+ x y))) (* z x)))) + +(test '#(0 1 2 3 4) + (do ((vec (make-vector 5)) + (i 0 (+ i 1))) + ((= i 5) vec) + (vector-set! vec i i))) + +(test 25 + (let ((x '(1 3 5 7 9))) + (do ((x x (cdr x)) + (sum 0 (+ sum (car x)))) + ((null? x) + sum)))) + +(test '((6 1 3) (-5 -2)) + (let loop ((numbers '(3 -2 1 6 -5)) (nonneg '()) (neg '())) + (cond + ((null? numbers) + (list nonneg neg)) + ((>= (car numbers) 0) + (loop (cdr numbers) (cons (car numbers) nonneg) neg)) + ((< (car numbers) 0) + (loop (cdr numbers) nonneg (cons (car numbers) neg)))))) + +(test '(list 3 4) `(list ,(+ 1 2) 4)) + +(test '(list a 'a) (let ((name 'a)) `(list ,name ',name))) + +(test '(a 3 4 5 6 b) + `(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b)) + +(test '(10 5 2 4 3 8) + `(10 5 ,(sqrt 4) ,@(map sqrt '(16 9)) 8)) + +(test '(a `(b ,(+ 1 2) ,(foo 4 d) e) f) + `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f)) + +(test '(a `(b ,x ,'y d) e) + (let ((name1 'x) + (name2 'y)) + `(a `(b ,,name1 ,',name2 d) e))) + +(test '(list 3 4) + (quasiquote (list (unquote (+ 1 2)) 4))) + +(test #t (eqv? 'a 'a)) + +(test #f (eqv? 'a 'b)) + +(test #t (eqv? '() '())) + +(test #f (eqv? (cons 1 2) (cons 1 2))) + +(test #f (eqv? (lambda () 1) (lambda () 2))) + +(test #t (let ((p (lambda (x) x))) (eqv? p p))) + +(test #t (eq? 'a 'a)) + +(test #f (eq? (list 'a) (list 'a))) + +(test #t (eq? '() '())) + +(test #t (eq? car car)) + +(test #t (let ((x '(a))) (eq? x x))) + +(test #t (let ((p (lambda (x) x))) (eq? p p))) + +(test #t (equal? 'a 'a)) + +(test #t (equal? '(a) '(a))) + +(test #t (equal? '(a (b) c) '(a (b) c))) + +(test #t (equal? "abc" "abc")) + +(test #t (equal? 2 2)) + +(test #t (equal? (make-vector 5 'a) (make-vector 5 'a))) + +(test 4 (max 3 4)) + +(test 4 (max 3.9 4)) + +(test 7 (+ 3 4)) + +(test 3 (+ 3)) + +(test 0 (+)) + +(test 4 (* 4)) + +(test 1 (*)) + +(test -1 (- 3 4)) + +(test -6 (- 3 4 5)) + +(test -3 (- 3)) + +(test 7 (abs -7)) + +(test 1 (modulo 13 4)) + +(test 1 (remainder 13 4)) + +(test 3 (modulo -13 4)) + +(test -1 (remainder -13 4)) + +(test -3 (modulo 13 -4)) + +(test 1 (remainder 13 -4)) + +(test -1 (modulo -13 -4)) + +(test -1 (remainder -13 -4)) + +(test 4 (gcd 32 -36)) + +(test 288 (lcm 32 -36)) + +(test -5 (floor -4.3)) + +(test -4 (ceiling -4.3)) + +(test -4 (truncate -4.3)) + +(test -4 (round -4.3)) + +(test 3 (floor 3.5)) + +(test 4 (ceiling 3.5)) + +(test 3 (truncate 3.5)) + +(test 4 (round 3.5)) + +(test 100 (string->number "100")) + +(test 256 (string->number "100" 16)) + +(test 100 (string->number "1e2")) + +(test #f (not 3)) + +(test #f (not (list 3))) + +(test #f (not '())) + +(test #f (not (list))) + +(test #f (not '())) + +(test #f (boolean? 0)) + +(test #f (boolean? '())) + +(test #t (pair? '(a . b))) + +(test #t (pair? '(a b c))) + +(test '(a) (cons 'a '())) + +(test '((a) b c d) (cons '(a) '(b c d))) + +(test '("a" b c) (cons "a" '(b c))) + +(test '(a . 3) (cons 'a 3)) + +(test '((a b) . c) (cons '(a b) 'c)) + +(test 'a (car '(a b c))) + +(test '(a) (car '((a) b c d))) + +(test 1 (car '(1 . 2))) + +(test '(b c d) (cdr '((a) b c d))) + +(test 2 (cdr '(1 . 2))) + +(test #t (list? '(a b c))) + +(test #t (list? '())) + +(test #f (list? '(a . b))) + +(test #f + (let ((x (list 'a))) + (set-cdr! x x) + (list? x))) + +(test '(a 7 c) (list 'a (+ 3 4) 'c)) + +(test '() (list)) + +(test 3 (length '(a b c))) + +(test 3 (length '(a (b) (c d e)))) + +(test 0 (length '())) + +(test '(x y) (append '(x) '(y))) + +(test '(a b c d) (append '(a) '(b c d))) + +(test '(a (b) (c)) (append '(a (b)) '((c)))) + +(test '(a b c . d) (append '(a b) '(c . d))) + +(test 'a (append '() 'a)) + +(test '(c b a) (reverse '(a b c))) + +(test '((e (f)) d (b c) a) (reverse '(a (b c) d (e (f))))) + +(test 'c (list-ref '(a b c d) 2)) + +(test '(a b c) (memq 'a '(a b c))) + +(test '(b c) (memq 'b '(a b c))) + +(test #f (memq 'a '(b c d))) + +(test #f (memq (list 'a) '(b (a) c))) + +(test '((a) c) (member (list 'a) '(b (a) c))) + +(test '(101 102) (memv 101 '(100 101 102))) + +(test #f (assq (list 'a) '(((a)) ((b)) ((c))))) + +(test '((a)) (assoc (list 'a) '(((a)) ((b)) ((c))))) + +(test '(5 7) (assv 5 '((2 3) (5 7) (11 13)))) + +(test #t (symbol? 'foo)) + +(test #t (symbol? (car '(a b)))) + +(test #f (symbol? "bar")) + +(test #t (symbol? 'nil)) + +(test #f (symbol? '())) + +(test "flying-fish" (symbol->string 'flying-fish)) + +(test "Martin" (symbol->string 'Martin)) + +(test "Malvina" (symbol->string (string->symbol "Malvina"))) + +(test '#(0 ("Sue" "Sue") "Anna") + (let ((vec (vector 0 '(2 2 2 2) "Anna"))) + (vector-set! vec 1 '("Sue" "Sue")) + vec)) + +(test '(dah dah didah) (vector->list '#(dah dah didah))) + +(test '#(dididit dah) (list->vector '(dididit dah))) + +(test #t (procedure? car)) + +(test #f (procedure? 'car)) + +(test #t (procedure? (lambda (x) (* x x)))) + +(test #f (procedure? '(lambda (x) (* x x)))) + +(test #t (call-with-current-continuation procedure?)) + +(test 7 (apply + (list 3 4))) + +(test '(b e h) (map cadr '((a b) (d e) (g h)))) + +(test '(1 4 27 256 3125) (map (lambda (n) (expt n n)) '(1 2 3 4 5))) + +(test '(5 7 9) (map + '(1 2 3) '(4 5 6))) + +(test '#(0 1 4 9 16) + (let ((v (make-vector 5))) + (for-each + (lambda (i) (vector-set! v i (* i i))) + '(0 1 2 3 4)) + v)) + +(test 3 (force (delay (+ 1 2)))) + +(test '(3 3) (let ((p (delay (+ 1 2)))) (list (force p) (force p)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(test-report) From e26fc9af8043f4826043d16f68b9bbcbe1dc1db6 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 30 Apr 2009 18:47:26 +0900 Subject: [PATCH 105/154] initial gc outline --- gc.c | 89 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ sexp.h | 2 ++ 2 files changed, 91 insertions(+) create mode 100644 gc.c diff --git a/gc.c b/gc.c new file mode 100644 index 00000000..0786bf4d --- /dev/null +++ b/gc.c @@ -0,0 +1,89 @@ +/* gc.c -- simple garbage collector */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#include + +#define SEXP_INITIAL_HEAP_SIZE 10000000 +#define SEXP_MINIMUM_OBJECT_SIZE (sexp_sizeof(flonum)) + +static char* sexp_heap; +static char* sexp_heap_end; +static sexp sexp_free_list; + +void *sexp_alloc (size_t size) { + sexp ls1, ls2, ls3; + try_alloc: + ls1=sexp_free_list; + for (ls2=sexp_cdr(ls1); sexp_pairp(ls2); ls1=ls2, ls2=sexp_cdr(ls2)) + if (sexp_car(ls2) >= size) { + if (sexp_car(ls2) >= size + SEXP_MINIMUM_OBJECT_SIZE) { + ls3 = (sexp) (((char*)ls2)+size); + sexp_car(ls3) = (sexp) (sexp_car(ls2) - size); + sexp_cdr(ls3) = sexp_cdr(ls2); + sexp_cdr(ls1) = sexp_cdr(ls3); + } else { + sexp_cdr(ls1) = sexp_cdr(ls2); + } + return ls2; + } + if (sexp_unbox_integer(sexp_gc()) >= size) { + goto try_alloc; + } else { + fprintf(stderr, "chibi: out of memory trying to allocate %ld bytes, aborting\n", size); + exit(70); + } +} + +void sexp_mark (sexp x) { + sexp *data; + sexp_uint_t i; + loop: + if ((! sexp_pointerp(x)) || sexp_mark(x)) + return; + sexp_mark(x) = 1; + switch (sexp_tag(x)) { + case SEXP_PAIR: + sexp_mark(sexp_car(x)); + x = sexp_cdr(x); + goto loop; + case SEXP_VECTOR: + data = sexp_vector_data(x); + for (i=sexp_vector_length(x)-1; i>=0; i--) + sexp_mark(data[i]); + } +} + +sexp sexp_sweep () { + sexp_uint_t freed=0, size; + sexp p=(sexp)sexp_heap, f=sexp_free_list; + /* XXXX make p skip over areas already in the free_list */ + while (p Date: Tue, 5 May 2009 03:16:09 +0900 Subject: [PATCH 106/154] passing context through all calls that can allocate memory in preparation for a native, thread-safe gc. --- Makefile | 4 +- defaults.h | 32 ++- eval.c | 598 +++++++++++++++++++++++++++-------------------------- eval.h | 1 + gc.c | 53 ++++- init.scm | 40 ++-- main.c | 36 ++-- opcodes.c | 7 +- sexp.c | 373 ++++++++++++++++----------------- sexp.h | 98 ++++----- 10 files changed, 658 insertions(+), 584 deletions(-) diff --git a/Makefile b/Makefile index c4166b8d..d23dd575 100644 --- a/Makefile +++ b/Makefile @@ -10,7 +10,9 @@ INCDIR=$(PREFIX)/include/chibi-scheme MODDIR=$(PREFIX)/share/chibi-scheme LDFLAGS=-lm -CFLAGS=-Wall -g -Os + +# -Oz for smaller size on darwin +CFLAGS=-Wall -g -Os -save-temps GC_OBJ=./gc/gc.a diff --git a/defaults.h b/defaults.h index add20406..2367f68f 100644 --- a/defaults.h +++ b/defaults.h @@ -20,6 +20,10 @@ #define USE_BOEHM 1 #endif +#ifndef USE_MALLOC +#define USE_MALLOC 0 +#endif + #ifndef USE_FLONUMS #define USE_FLONUMS 1 #endif @@ -58,16 +62,22 @@ #if USE_BOEHM #include "gc/include/gc.h" -#define sexp_alloc GC_malloc -#define sexp_alloc_atomic GC_malloc_atomic -#define sexp_realloc GC_realloc -#define sexp_free(x) -#define sexp_deep_free(x) -#else -#define sexp_alloc malloc -#define sexp_alloc_atomic sexp_alloc -#define sexp_realloc realloc -#define sexp_free free -void sexp_deep_free(sexp obj); +#define sexp_alloc(ctx, size) GC_malloc(size) +#define sexp_alloc_atomic(ctx, size) GC_malloc_atomic(size) +#define sexp_realloc(ctx, x, size) GC_realloc(x, size) +#define sexp_free(ctx, x) +#define sexp_deep_free(ctx, x) +#elif USE_MALLOC +#define sexp_alloc(ctx, size) malloc(size) +#define sexp_alloc_atomic(ctx, size) malloc(size) +#define sexp_realloc(ctx, x, size) realloc(x, size) +#define sexp_free(ctx, x) free(x) +void sexp_deep_free(sexp ctx, sexp obj); +#else /* native gc */ +void *sexp_alloc(sexp ctx, size_t size); +#define sexp_alloc_atomic sexp_alloc +void *sexp_realloc(sexp ctx, sexp x, size_t size); +#define sexp_free(ctx, x) +#define sexp_deep_free(ctx, x) #endif diff --git a/eval.c b/eval.c index 28cc7b61..bc384d9b 100644 --- a/eval.c +++ b/eval.c @@ -23,8 +23,8 @@ static sexp the_cur_in_symbol, the_cur_out_symbol, the_cur_err_symbol; static sexp analyze (sexp x, sexp context); static void generate (sexp x, sexp context); -static sexp sexp_make_null_env (sexp version); -static sexp sexp_make_standard_env (sexp version); +static sexp sexp_make_null_env (sexp ctx, sexp version); +static sexp sexp_make_standard_env (sexp ctx, sexp version); /********************** environment utilities ***************************/ @@ -41,13 +41,13 @@ static sexp env_cell(sexp e, sexp key) { return NULL; } -static sexp env_cell_create(sexp e, sexp key, sexp value) { +static sexp env_cell_create(sexp ctx, sexp e, sexp key, sexp value) { sexp cell = env_cell(e, key); if (! cell) { - cell = sexp_cons(key, value); + cell = sexp_cons(ctx, key, value); while (sexp_env_parent(e)) e = sexp_env_parent(e); - sexp_env_bindings(e) = sexp_cons(cell, sexp_env_bindings(e)); + sexp_env_bindings(e) = sexp_cons(ctx, cell, sexp_env_bindings(e)); } return cell; } @@ -60,32 +60,32 @@ static sexp env_global_ref(sexp e, sexp key, sexp dflt) { return (cell ? sexp_cdr(cell) : dflt); } -static void env_define(sexp e, sexp key, sexp value) { - sexp cell = sexp_assq(key, sexp_env_bindings(e)); +static void env_define(sexp ctx, sexp e, sexp key, sexp value) { + sexp cell = sexp_assq(ctx, key, sexp_env_bindings(e)); if (cell != SEXP_FALSE) sexp_cdr(cell) = value; else - sexp_push(sexp_env_bindings(e), sexp_cons(key, value)); + sexp_push(ctx, sexp_env_bindings(e), sexp_cons(ctx, key, value)); } -static sexp extend_env (sexp env, sexp vars, sexp value) { - sexp e = sexp_alloc_type(env, SEXP_ENV); +static sexp extend_env (sexp ctx, sexp env, sexp vars, sexp value) { + sexp e = sexp_alloc_type(ctx, env, SEXP_ENV); sexp_env_parent(e) = env; sexp_env_bindings(e) = SEXP_NULL; for ( ; sexp_pairp(vars); vars = sexp_cdr(vars)) - sexp_push(sexp_env_bindings(e), sexp_cons(sexp_car(vars), value)); + sexp_push(ctx, sexp_env_bindings(e), sexp_cons(ctx, sexp_car(vars), value)); return e; } -static sexp sexp_reverse_flatten_dot (sexp ls) { +static sexp sexp_reverse_flatten_dot (sexp ctx, sexp ls) { sexp res; for (res=SEXP_NULL; sexp_pairp(ls); ls=sexp_cdr(ls)) - sexp_push(res, sexp_car(ls)); - return (sexp_nullp(ls) ? res : sexp_cons(ls, res)); + sexp_push(ctx, res, sexp_car(ls)); + return (sexp_nullp(ls) ? res : sexp_cons(ctx, ls, res)); } -static sexp sexp_flatten_dot (sexp ls) { - return sexp_nreverse(sexp_reverse_flatten_dot(ls)); +static sexp sexp_flatten_dot (sexp ctx, sexp ls) { + return sexp_nreverse(ctx, sexp_reverse_flatten_dot(ctx, ls)); } static int sexp_param_index (sexp lambda, sexp name) { @@ -108,7 +108,7 @@ static int sexp_param_index (sexp lambda, sexp name) { static void shrink_bcode(sexp context, sexp_uint_t i) { sexp tmp; if (sexp_bytecode_length(sexp_context_bc(context)) != i) { - tmp = sexp_alloc_tagged(sexp_sizeof(bytecode) + i, SEXP_BYTECODE); + tmp = sexp_alloc_tagged(context, sexp_sizeof(bytecode) + i, SEXP_BYTECODE); sexp_bytecode_name(tmp) = SEXP_FALSE; sexp_bytecode_length(tmp) = i; sexp_bytecode_literals(tmp) @@ -124,7 +124,8 @@ static void expand_bcode(sexp context, sexp_uint_t size) { sexp tmp; if (sexp_bytecode_length(sexp_context_bc(context)) < (sexp_context_pos(context))+size) { - tmp = sexp_alloc_tagged(sexp_sizeof(bytecode) + tmp = sexp_alloc_tagged(context, + sexp_sizeof(bytecode) + sexp_bytecode_length(sexp_context_bc(context))*2, SEXP_BYTECODE); sexp_bytecode_name(tmp) = SEXP_FALSE; @@ -156,12 +157,12 @@ static void emit_push(sexp obj, sexp context) { emit(OP_PUSH, context); emit_word((sexp_uint_t)obj, context); if (sexp_pointerp(obj)) - sexp_push(sexp_bytecode_literals(sexp_context_bc(context)), obj); + sexp_push(context, sexp_bytecode_literals(sexp_context_bc(context)), obj); } -static sexp sexp_make_procedure(sexp flags, sexp num_args, +static sexp sexp_make_procedure(sexp ctx, sexp flags, sexp num_args, sexp bc, sexp vars) { - sexp proc = sexp_alloc_type(procedure, SEXP_PROCEDURE); + sexp proc = sexp_alloc_type(ctx, procedure, SEXP_PROCEDURE); sexp_procedure_flags(proc) = (char) (sexp_uint_t) flags; sexp_procedure_num_args(proc) = (unsigned short) (sexp_uint_t) num_args; sexp_procedure_code(proc) = bc; @@ -169,18 +170,18 @@ static sexp sexp_make_procedure(sexp flags, sexp num_args, return proc; } -static sexp sexp_make_macro (sexp p, sexp e) { - sexp mac = sexp_alloc_type(macro, SEXP_MACRO); +static sexp sexp_make_macro (sexp ctx, sexp p, sexp e) { + sexp mac = sexp_alloc_type(ctx, macro, SEXP_MACRO); sexp_macro_env(mac) = e; sexp_macro_proc(mac) = p; return mac; } -static sexp sexp_make_synclo (sexp env, sexp fv, sexp expr) { +static sexp sexp_make_synclo (sexp ctx, sexp env, sexp fv, sexp expr) { sexp res; if (sexp_synclop(expr)) return expr; - res = sexp_alloc_type(synclo, SEXP_SYNCLO); + res = sexp_alloc_type(ctx, synclo, SEXP_SYNCLO); sexp_synclo_env(res) = env; sexp_synclo_free_vars(res) = fv; sexp_synclo_expr(res) = expr; @@ -189,8 +190,8 @@ static sexp sexp_make_synclo (sexp env, sexp fv, sexp expr) { /* internal AST */ -static sexp sexp_make_lambda(sexp params) { - sexp res = sexp_alloc_type(lambda, SEXP_LAMBDA); +static sexp sexp_make_lambda(sexp ctx, sexp params) { + sexp res = sexp_alloc_type(ctx, lambda, SEXP_LAMBDA); sexp_lambda_name(res) = SEXP_FALSE; sexp_lambda_params(res) = params; sexp_lambda_fv(res) = SEXP_NULL; @@ -200,42 +201,42 @@ static sexp sexp_make_lambda(sexp params) { return res; } -static sexp sexp_make_set(sexp var, sexp value) { - sexp res = sexp_alloc_type(set, SEXP_SET); +static sexp sexp_make_set(sexp ctx, sexp var, sexp value) { + sexp res = sexp_alloc_type(ctx, set, SEXP_SET); sexp_set_var(res) = var; sexp_set_value(res) = value; return res; } -static sexp sexp_make_ref(sexp name, sexp cell) { - sexp res = sexp_alloc_type(ref, SEXP_REF); +static sexp sexp_make_ref(sexp ctx, sexp name, sexp cell) { + sexp res = sexp_alloc_type(ctx, ref, SEXP_REF); sexp_ref_name(res) = name; sexp_ref_cell(res) = cell; return res; } -static sexp sexp_make_cnd(sexp test, sexp pass, sexp fail) { - sexp res = sexp_alloc_type(cnd, SEXP_CND); +static sexp sexp_make_cnd(sexp ctx, sexp test, sexp pass, sexp fail) { + sexp res = sexp_alloc_type(ctx, cnd, SEXP_CND); sexp_cnd_test(res) = test; sexp_cnd_pass(res) = pass; sexp_cnd_fail(res) = fail; return res; } -static sexp sexp_make_lit(sexp value) { - sexp res = sexp_alloc_type(lit, SEXP_LIT); +static sexp sexp_make_lit(sexp ctx, sexp value) { + sexp res = sexp_alloc_type(ctx, lit, SEXP_LIT); sexp_lit_value(res) = value; return res; } -static sexp sexp_make_context(sexp *stack, sexp env) { - sexp res = sexp_alloc_type(context, SEXP_CONTEXT); +static sexp sexp_make_context(sexp ctx, sexp *stack, sexp env) { + sexp res = sexp_alloc_type(ctx, context, SEXP_CONTEXT); if (! stack) - stack = (sexp*) sexp_alloc(sizeof(sexp)*INIT_STACK_SIZE); + stack = (sexp*) sexp_alloc(ctx, sizeof(sexp)*INIT_STACK_SIZE); if (! env) - env = sexp_make_standard_env(sexp_make_integer(5)); + env = sexp_make_standard_env(ctx, sexp_make_integer(5)); sexp_context_bc(res) - = sexp_alloc_tagged(sexp_sizeof(bytecode)+INIT_BCODE_SIZE, SEXP_BYTECODE); + = sexp_alloc_tagged(ctx, sexp_sizeof(bytecode)+INIT_BCODE_SIZE, SEXP_BYTECODE); sexp_bytecode_name(sexp_context_bc(res)) = SEXP_FALSE; sexp_bytecode_length(sexp_context_bc(res)) = INIT_BCODE_SIZE; sexp_bytecode_literals(sexp_context_bc(res)) = SEXP_NULL; @@ -252,7 +253,8 @@ static sexp sexp_make_context(sexp *stack, sexp env) { } static sexp sexp_child_context(sexp context, sexp lambda) { - sexp ctx = sexp_make_context(sexp_context_stack(context), + sexp ctx = sexp_make_context(context, + sexp_context_stack(context), sexp_context_env(context)); sexp_context_lambda(ctx) = lambda; sexp_context_env(ctx) = sexp_context_env(context); @@ -264,28 +266,29 @@ static sexp sexp_child_context(sexp context, sexp lambda) { #define sexp_idp(x) (sexp_symbolp(x) || (sexp_synclop(x) && sexp_symbolp(sexp_synclo_expr(x)))) -static sexp sexp_identifierp (sexp x) { +static sexp sexp_identifierp (sexp ctx, sexp x) { return sexp_make_boolean(sexp_idp(x)); } -static sexp sexp_syntactic_closure_expr (sexp x) { +static sexp sexp_syntactic_closure_expr (sexp ctx, sexp x) { return (sexp_synclop(x) ? sexp_synclo_expr(x) : x); } -static sexp sexp_strip_syntactic_closures (sexp x) { +static sexp sexp_strip_synclos (sexp ctx, sexp x) { loop: if (sexp_synclop(x)) { x = sexp_synclo_expr(x); goto loop; } else if (sexp_pairp(x)) { - return sexp_cons(sexp_strip_syntactic_closures(sexp_car(x)), - sexp_strip_syntactic_closures(sexp_cdr(x))); + return sexp_cons(ctx, + sexp_strip_synclos(ctx, sexp_car(x)), + sexp_strip_synclos(ctx, sexp_cdr(x))); } else { return x; } } -static sexp sexp_identifier_eq (sexp e1, sexp id1, sexp e2, sexp id2) { +static sexp sexp_identifier_eq(sexp ctx, sexp e1, sexp id1, sexp e2, sexp id2) { sexp cell, lam1=SEXP_FALSE, lam2=SEXP_FALSE; if (sexp_synclop(id1)) { e1 = sexp_synclo_env(id1); @@ -306,10 +309,10 @@ static sexp sexp_identifier_eq (sexp e1, sexp id1, sexp e2, sexp id2) { /************************* the compiler ***************************/ -static sexp sexp_compile_error(char *message, sexp irritants) { - return sexp_make_exception(the_compile_error_symbol, - sexp_c_string(message), - irritants, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE); +static sexp sexp_compile_error(sexp ctx, char *message, sexp obj) { + return sexp_make_exception(ctx, the_compile_error_symbol, + sexp_c_string(ctx, message), sexp_list1(ctx, obj), + SEXP_FALSE, SEXP_FALSE, SEXP_FALSE); } #define analyze_check_exception(x) do {if (sexp_exceptionp(x)) \ @@ -324,9 +327,9 @@ static sexp analyze_app (sexp x, sexp context) { sexp res=SEXP_NULL, tmp; for ( ; sexp_pairp(x); x=sexp_cdr(x)) { analyze_bind(tmp, sexp_car(x), context); - sexp_push(res, tmp); + sexp_push(context, res, tmp); } - return sexp_nreverse(res); + return sexp_nreverse(context, res); } static sexp analyze_seq (sexp ls, sexp context) { @@ -336,7 +339,7 @@ static sexp analyze_seq (sexp ls, sexp context) { else if (sexp_nullp(sexp_cdr(ls))) res = analyze(sexp_car(ls), context); else { - res = sexp_alloc_type(seq, SEXP_SEQ); + res = sexp_alloc_type(context, seq, SEXP_SEQ); tmp = analyze_app(ls, context); analyze_check_exception(tmp); sexp_seq_ls(res) = tmp; @@ -349,43 +352,44 @@ static sexp analyze_var_ref (sexp x, sexp context) { cell = env_cell(env, x); if (! cell) { if (sexp_synclop(x)) { - if (sexp_memq(x, sexp_context_fv(context)) != SEXP_FALSE) + if (sexp_memq(context, x, sexp_context_fv(context)) != SEXP_FALSE) env = sexp_synclo_env(x); x = sexp_synclo_expr(x); } - cell = env_cell_create(env, x, SEXP_UNDEF); + cell = env_cell_create(context, env, x, SEXP_UNDEF); } if (sexp_macrop(sexp_cdr(cell)) || sexp_corep(sexp_cdr(cell))) - return sexp_compile_error("invalid use of syntax as value", sexp_list1(x)); - return sexp_make_ref(x, cell); + return sexp_compile_error(context, "invalid use of syntax as value", x); + return sexp_make_ref(context, x, cell); } static sexp analyze_set (sexp x, sexp context) { sexp ref, value; ref = analyze_var_ref(sexp_cadr(x), context); if (sexp_lambdap(sexp_ref_loc(ref))) - sexp_insert(sexp_lambda_sv(sexp_ref_loc(ref)), sexp_ref_name(ref)); + sexp_insert(context, sexp_lambda_sv(sexp_ref_loc(ref)), sexp_ref_name(ref)); analyze_check_exception(ref); analyze_bind(value, sexp_caddr(x), context); - return sexp_make_set(ref, value); + return sexp_make_set(context, ref, value); } static sexp analyze_lambda (sexp x, sexp context) { sexp res, body, ls, tmp, name, value, defs=SEXP_NULL; /* verify syntax */ if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) - return sexp_compile_error("bad lambda syntax", sexp_list1(x)); + return sexp_compile_error(context, "bad lambda syntax", x); for (ls=sexp_cadr(x); sexp_pairp(ls); ls=sexp_cdr(ls)) if (! sexp_idp(sexp_car(ls))) - return sexp_compile_error("non-symbol parameter", sexp_list1(x)); - else if (sexp_memq(sexp_car(ls), sexp_cdr(ls)) != SEXP_FALSE) - return sexp_compile_error("duplicate parameter", sexp_list1(x)); + return sexp_compile_error(context, "non-symbol parameter", x); + else if (sexp_memq(context, sexp_car(ls), sexp_cdr(ls)) != SEXP_FALSE) + return sexp_compile_error(context, "duplicate parameter", x); /* build lambda and analyze body */ - res = sexp_make_lambda(sexp_cadr(x)); + res = sexp_make_lambda(context, sexp_cadr(x)); context = sexp_child_context(context, res); sexp_context_env(context) - = extend_env(sexp_context_env(context), - sexp_flatten_dot(sexp_lambda_params(res)), + = extend_env(context, + sexp_context_env(context), + sexp_flatten_dot(context, sexp_lambda_params(res)), res); sexp_env_lambda(sexp_context_env(context)) = res; body = analyze_seq(sexp_cddr(x), context); @@ -395,23 +399,27 @@ static sexp analyze_lambda (sexp x, sexp context) { tmp = sexp_car(ls); if (sexp_pairp(sexp_cadr(tmp))) { name = sexp_caadr(tmp); - value = analyze_lambda(sexp_cons(SEXP_VOID, sexp_cons(sexp_cdadr(tmp), - sexp_cddr(tmp))), + value = analyze_lambda(sexp_cons(context, + SEXP_VOID, + sexp_cons(context, + sexp_cdadr(tmp), + sexp_cddr(tmp))), context); } else { name = sexp_cadr(tmp); value = analyze(sexp_caddr(tmp), context); } analyze_check_exception(value); - sexp_push(defs, sexp_make_set(analyze_var_ref(name, context), value)); + sexp_push(context, defs, + sexp_make_set(context, analyze_var_ref(name, context), value)); } if (sexp_pairp(defs)) { if (! sexp_seqp(body)) { - tmp = sexp_alloc_type(seq, SEXP_SEQ); - sexp_seq_ls(tmp) = sexp_list1(body); + tmp = sexp_alloc_type(context, seq, SEXP_SEQ); + sexp_seq_ls(tmp) = sexp_list1(context, body); body = tmp; } - sexp_seq_ls(body) = sexp_append(defs, sexp_seq_ls(body)); + sexp_seq_ls(body) = sexp_append2(context, defs, sexp_seq_ls(body)); } sexp_lambda_body(res) = body; return res; @@ -423,32 +431,35 @@ static sexp analyze_if (sexp x, sexp context) { analyze_bind(pass, sexp_caddr(x), context); fail_expr = sexp_pairp(sexp_cdddr(x)) ? sexp_cadddr(x) : SEXP_VOID; analyze_bind(fail, fail_expr, context); - return sexp_make_cnd(test, pass, fail); + return sexp_make_cnd(context, test, pass, fail); } static sexp analyze_define (sexp x, sexp context) { sexp ref, name, value, env = sexp_context_env(context); name = (sexp_pairp(sexp_cadr(x)) ? sexp_caadr(x) : sexp_cadr(x)); if (sexp_env_lambda(env) && sexp_lambdap(sexp_env_lambda(env))) { - sexp_push(sexp_env_bindings(env), - sexp_cons(name, sexp_context_lambda(context))); - sexp_push(sexp_lambda_sv(sexp_env_lambda(env)), name); - sexp_push(sexp_lambda_locals(sexp_env_lambda(env)), name); - sexp_push(sexp_lambda_defs(sexp_env_lambda(env)), x); + sexp_push(context, sexp_env_bindings(env), + sexp_cons(context, name, sexp_context_lambda(context))); + sexp_push(context, sexp_lambda_sv(sexp_env_lambda(env)), name); + sexp_push(context, sexp_lambda_locals(sexp_env_lambda(env)), name); + sexp_push(context, sexp_lambda_defs(sexp_env_lambda(env)), x); return SEXP_VOID; } else { - env_cell_create(env, name, SEXP_VOID); + env_cell_create(context, env, name, SEXP_VOID); } if (sexp_pairp(sexp_cadr(x))) - value = analyze_lambda(sexp_cons(SEXP_VOID, - sexp_cons(sexp_cdadr(x), sexp_cddr(x))), + value = analyze_lambda(sexp_cons(context, + SEXP_VOID, + sexp_cons(context, + sexp_cdadr(x), + sexp_cddr(x))), context); else value = analyze(sexp_caddr(x), context); analyze_check_exception(value); ref = analyze_var_ref(name, context); analyze_check_exception(ref); - return sexp_make_set(ref, value); + return sexp_make_set(context, ref, value); } static sexp analyze_bind_syntax (sexp ls, sexp eval_ctx, sexp bind_ctx) { @@ -457,20 +468,23 @@ static sexp analyze_bind_syntax (sexp ls, sexp eval_ctx, sexp bind_ctx) { proc = eval_in_context(sexp_cadar(ls), eval_ctx); analyze_check_exception(proc); if (sexp_procedurep(proc)) - sexp_push(sexp_env_bindings(sexp_context_env(bind_ctx)), - sexp_cons(sexp_caar(ls), - sexp_make_macro(proc, sexp_context_env(eval_ctx)))); + sexp_push(eval_ctx, + sexp_env_bindings(sexp_context_env(bind_ctx)), + sexp_cons(eval_ctx, + sexp_caar(ls), + sexp_make_macro(eval_ctx, proc, + sexp_context_env(eval_ctx)))); } return SEXP_VOID; } -static sexp analyze_define_syntax (sexp x, sexp context) { - return analyze_bind_syntax(sexp_list1(sexp_cdr(x)), context, context); +static sexp analyze_define_syntax (sexp x, sexp ctx) { + return analyze_bind_syntax(sexp_list1(ctx, sexp_cdr(x)), ctx, ctx); } static sexp analyze_let_syntax (sexp x, sexp context) { sexp env, ctx, tmp; - env = sexp_alloc_type(env, SEXP_ENV); + env = sexp_alloc_type(context, env, SEXP_ENV); sexp_env_parent(env) = sexp_env_parent(sexp_context_env(context)); sexp_env_bindings(env) = sexp_env_bindings(sexp_context_env(context)); ctx = sexp_child_context(context, sexp_context_lambda(context)); @@ -490,8 +504,8 @@ static sexp analyze (sexp x, sexp context) { sexp op, cell, res; loop: if (sexp_pairp(x)) { - if (sexp_listp(x) == SEXP_FALSE) { - res = sexp_compile_error("dotted list in source", sexp_list1(x)); + if (sexp_listp(context, x) == SEXP_FALSE) { + res = sexp_compile_error(context, "dotted list in source", x); } else if (sexp_idp(sexp_car(x))) { cell = env_cell(sexp_context_env(context), sexp_car(x)); if (! cell && sexp_synclop(sexp_car(x))) @@ -512,7 +526,8 @@ static sexp analyze (sexp x, sexp context) { case CORE_BEGIN: res = analyze_seq(sexp_cdr(x), context); break; case CORE_QUOTE: - res = sexp_make_lit(sexp_strip_syntactic_closures(sexp_cadr(x))); + res + = sexp_make_lit(context, sexp_strip_synclos(context, sexp_cadr(x))); break; case CORE_DEFINE_SYNTAX: res = analyze_define_syntax(x, context); break; @@ -521,26 +536,26 @@ static sexp analyze (sexp x, sexp context) { case CORE_LETREC_SYNTAX: res = analyze_letrec_syntax(x, context); break; default: - res = sexp_compile_error("unknown core form", sexp_list1(op)); break; + res = sexp_compile_error(context, "unknown core form", op); break; } } else if (sexp_macrop(op)) { /* if (in_repl_p) sexp_debug("expand: ", x, context); */ x = apply(sexp_macro_proc(op), - sexp_list3(x, sexp_context_env(context), sexp_macro_env(op)), + sexp_list3(context, x, sexp_context_env(context), sexp_macro_env(op)), sexp_child_context(context, sexp_context_lambda(context))); /* if (in_repl_p) sexp_debug(" => ", x, context); */ goto loop; } else if (sexp_opcodep(op)) { - res = sexp_length(sexp_cdr(x)); + res = sexp_length(context, sexp_cdr(x)); if (sexp_unbox_integer(res) < sexp_opcode_num_args(op)) { - res = sexp_compile_error("not enough args for opcode", sexp_list1(x)); + res = sexp_compile_error(context, "not enough args for opcode", x); } else if ((sexp_unbox_integer(res) > sexp_opcode_num_args(op)) && (! sexp_opcode_variadic_p(op))) { - res = sexp_compile_error("too many args for opcode", sexp_list1(x)); + res = sexp_compile_error(context, "too many args for opcode", x); } else { res = analyze_app(sexp_cdr(x), context); analyze_check_exception(res); - sexp_push(res, op); + sexp_push(context, res, op); } } else { res = analyze_app(x, context); @@ -553,8 +568,9 @@ static sexp analyze (sexp x, sexp context) { } else if (sexp_synclop(x)) { context = sexp_child_context(context, sexp_context_lambda(context)); sexp_context_env(context) = sexp_synclo_env(x); - sexp_context_fv(context) = sexp_append(sexp_synclo_free_vars(x), - sexp_context_fv(context)); + sexp_context_fv(context) = sexp_append2(context, + sexp_synclo_free_vars(x), + sexp_context_fv(context)); x = sexp_synclo_expr(x); goto loop; } else { @@ -633,7 +649,7 @@ static void generate_non_global_ref (sexp name, sexp cell, sexp lambda, emit(OP_CLOSURE_REF, context); emit_word(i, context); } - if (unboxp && (sexp_memq(name, sexp_lambda_sv(loc)) != SEXP_FALSE)) + if (unboxp && (sexp_memq(context, name, sexp_lambda_sv(loc)) != SEXP_FALSE)) emit(OP_CDR, context); sexp_context_depth(context)++; } @@ -669,7 +685,8 @@ static void generate_set (sexp set, sexp context) { emit(OP_SET_CDR, context); } else { lambda = sexp_ref_loc(ref); - if (sexp_memq(sexp_ref_name(ref), sexp_lambda_sv(lambda)) != SEXP_FALSE) { + if (sexp_memq(context, sexp_ref_name(ref), sexp_lambda_sv(lambda)) + != SEXP_FALSE) { /* stack or closure mutable vars are boxed */ generate_ref(ref, context, 0); emit(OP_SET_CDR, context); @@ -684,7 +701,8 @@ static void generate_set (sexp set, sexp context) { static void generate_opcode_app (sexp app, sexp context) { sexp ls, op = sexp_car(app); - sexp_sint_t i, num_args = sexp_unbox_integer(sexp_length(sexp_cdr(app))); + sexp_sint_t i, num_args; + num_args = sexp_unbox_integer(sexp_length(context, sexp_cdr(app))); sexp_context_tailp(context) = 0; /* maybe push the default for an optional argument */ @@ -702,7 +720,7 @@ static void generate_opcode_app (sexp app, sexp context) { /* push the arguments onto the stack */ ls = ((sexp_opcode_inverse(op) && (sexp_opcode_class(op) != OPC_ARITHMETIC_INV)) - ? sexp_cdr(app) : sexp_reverse(sexp_cdr(app))); + ? sexp_cdr(app) : sexp_reverse(context, sexp_cdr(app))); for ( ; sexp_pairp(ls); ls = sexp_cdr(ls)) generate(sexp_car(ls), context); @@ -763,12 +781,13 @@ static void generate_opcode_app (sexp app, sexp context) { static void generate_general_app (sexp app, sexp context) { sexp ls; - sexp_uint_t len = sexp_unbox_integer(sexp_length(sexp_cdr(app))), + sexp_uint_t len = sexp_unbox_integer(sexp_length(context, sexp_cdr(app))), tailp = sexp_context_tailp(context); /* push the arguments onto the stack */ sexp_context_tailp(context) = 0; - for (ls = sexp_reverse(sexp_cdr(app)); sexp_pairp(ls); ls = sexp_cdr(ls)) + for (ls = sexp_reverse(context, sexp_cdr(app)); sexp_pairp(ls); + ls = sexp_cdr(ls)) generate(sexp_car(ls), context); /* push the operator onto the stack */ @@ -794,7 +813,8 @@ static void generate_lambda (sexp lambda, sexp context) { prev_lambda = sexp_context_lambda(context); prev_fv = sexp_lambdap(prev_lambda) ? sexp_lambda_fv(prev_lambda) : SEXP_NULL; fv = sexp_lambda_fv(lambda); - ctx = sexp_make_context(sexp_context_stack(context), + ctx = sexp_make_context(context, + sexp_context_stack(context), sexp_context_env(context)); sexp_context_lambda(ctx) = lambda; /* allocate space for local vars */ @@ -815,19 +835,19 @@ static void generate_lambda (sexp lambda, sexp context) { } sexp_context_tailp(ctx) = 1; generate(sexp_lambda_body(lambda), ctx); - flags = sexp_make_integer((sexp_listp(sexp_lambda_params(lambda))==SEXP_FALSE) - ? 1 : 0); - len = sexp_length(sexp_lambda_params(lambda)); + flags = sexp_make_integer((sexp_listp(context, sexp_lambda_params(lambda)) + == SEXP_FALSE) ? 1 : 0); + len = sexp_length(context, sexp_lambda_params(lambda)); bc = finalize_bytecode(ctx); sexp_bytecode_name(bc) = sexp_lambda_name(lambda); if (sexp_nullp(fv)) { /* shortcut, no free vars */ - vec = sexp_make_vector(sexp_make_integer(0), SEXP_VOID); - generate_lit(sexp_make_procedure(flags, len, bc, vec), context); + vec = sexp_make_vector(context, sexp_make_integer(0), SEXP_VOID); + generate_lit(sexp_make_procedure(context, flags, len, bc, vec), context); } else { /* push the closed vars */ emit_push(SEXP_VOID, context); - emit_push(sexp_length(fv), context); + emit_push(sexp_length(context, fv), context); emit(OP_MAKE_VECTOR, context); sexp_context_depth(context)--; for (k=0; sexp_pairp(fv); fv=sexp_cdr(fv), k++) { @@ -881,93 +901,93 @@ static void generate (sexp x, sexp context) { } } -static sexp insert_free_var (sexp x, sexp fv) { +static sexp insert_free_var (sexp ctx, sexp x, sexp fv) { sexp name=sexp_ref_name(x), loc=sexp_ref_loc(x), ls; for (ls=fv; sexp_pairp(ls); ls=sexp_cdr(ls)) if ((name == sexp_ref_name(sexp_car(ls))) && (loc == sexp_ref_loc(sexp_car(ls)))) return fv; - return sexp_cons(x, fv); + return sexp_cons(ctx, x, fv); } -static sexp union_free_vars (sexp fv1, sexp fv2) { +static sexp union_free_vars (sexp ctx, sexp fv1, sexp fv2) { if (sexp_nullp(fv2)) return fv1; for ( ; sexp_pairp(fv1); fv1=sexp_cdr(fv1)) - fv2 = insert_free_var(sexp_car(fv1), fv2); + fv2 = insert_free_var(ctx, sexp_car(fv1), fv2); return fv2; } -static sexp diff_free_vars (sexp lambda, sexp fv, sexp params) { +static sexp diff_free_vars (sexp ctx, sexp lambda, sexp fv, sexp params) { sexp res = SEXP_NULL; for ( ; sexp_pairp(fv); fv=sexp_cdr(fv)) if ((sexp_ref_loc(sexp_car(fv)) != lambda) - || (sexp_memq(sexp_ref_name(sexp_car(fv)), params) == SEXP_FALSE)) - sexp_push(res, sexp_car(fv)); + || (sexp_memq(NULL, sexp_ref_name(sexp_car(fv)), params) + == SEXP_FALSE)) + sexp_push(ctx, res, sexp_car(fv)); return res; } -static sexp free_vars (sexp x, sexp fv) { +static sexp free_vars (sexp ctx, sexp x, sexp fv) { sexp fv1, fv2; if (sexp_lambdap(x)) { - fv1 = free_vars(sexp_lambda_body(x), SEXP_NULL); - fv2 = diff_free_vars(x, - fv1, - sexp_append(sexp_lambda_locals(x), - sexp_flatten_dot(sexp_lambda_params(x)))); + fv1 = free_vars(ctx, sexp_lambda_body(x), SEXP_NULL); + fv2 = diff_free_vars(ctx, x, fv1, + sexp_append2(ctx, + sexp_lambda_locals(x), + sexp_flatten_dot(ctx, + sexp_lambda_params(x)))); sexp_lambda_fv(x) = fv2; - fv = union_free_vars(fv2, fv); + fv = union_free_vars(ctx, fv2, fv); } else if (sexp_pairp(x)) { for ( ; sexp_pairp(x); x=sexp_cdr(x)) - fv = free_vars(sexp_car(x), fv); + fv = free_vars(ctx, sexp_car(x), fv); } else if (sexp_cndp(x)) { - fv = free_vars(sexp_cnd_test(x), fv); - fv = free_vars(sexp_cnd_pass(x), fv); - fv = free_vars(sexp_cnd_fail(x), fv); + fv = free_vars(ctx, sexp_cnd_test(x), fv); + fv = free_vars(ctx, sexp_cnd_pass(x), fv); + fv = free_vars(ctx, sexp_cnd_fail(x), fv); } else if (sexp_seqp(x)) { for (x=sexp_seq_ls(x); sexp_pairp(x); x=sexp_cdr(x)) - fv = free_vars(sexp_car(x), fv); + fv = free_vars(ctx, sexp_car(x), fv); } else if (sexp_setp(x)) { - fv = free_vars(sexp_set_value(x), fv); - fv = free_vars(sexp_set_var(x), fv); + fv = free_vars(ctx, sexp_set_value(x), fv); + fv = free_vars(ctx, sexp_set_var(x), fv); } else if (sexp_refp(x) && sexp_lambdap(sexp_ref_loc(x))) { - fv = insert_free_var(x, fv); + fv = insert_free_var(ctx, x, fv); } else if (sexp_synclop(x)) { - fv = free_vars(sexp_synclo_expr(x), fv); + fv = free_vars(ctx, sexp_synclo_expr(x), fv); } return fv; } -static sexp make_param_list(sexp_uint_t i) { +static sexp make_param_list(sexp ctx, sexp_uint_t i) { sexp res = SEXP_NULL; char sym[2]="a"; for (sym[0]+=i; i>0; i--) { sym[0] = sym[0]-1; - res = sexp_cons(sexp_intern(sym), res); + res = sexp_cons(ctx, sexp_intern(ctx, sym), res); } return res; } -static sexp make_opcode_procedure (sexp op, sexp_uint_t i, sexp env, +static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i, sexp env, sexp *stack, sexp_sint_t top) { sexp context, lambda, params, refs, ls, bc, res; if (i == sexp_opcode_num_args(op) && sexp_opcode_proc(op)) return sexp_opcode_proc(op); - params = make_param_list(i); - lambda = sexp_make_lambda(params); - env = extend_env(env, params, lambda); - context = sexp_make_context(stack, env); + params = make_param_list(ctx, i); + lambda = sexp_make_lambda(ctx, params); + env = extend_env(ctx, env, params, lambda); + context = sexp_make_context(ctx, stack, env); sexp_context_lambda(context) = lambda; sexp_context_top(context) = top; for (ls=params, refs=SEXP_NULL; sexp_pairp(ls); ls=sexp_cdr(ls)) - sexp_push(refs, sexp_make_ref(sexp_car(ls), env_cell(env, sexp_car(ls)))); - generate_opcode_app(sexp_cons(op, sexp_reverse(refs)), context); + sexp_push(context, refs, sexp_make_ref(context, sexp_car(ls), env_cell(env, sexp_car(ls)))); + generate_opcode_app(sexp_cons(context, op, sexp_reverse(context, refs)), context); bc = finalize_bytecode(context); - sexp_bytecode_name(bc) = sexp_c_string(sexp_opcode_name(op)); - res = sexp_make_procedure(sexp_make_integer(0), - sexp_make_integer(i), - bc, - SEXP_VOID); + sexp_bytecode_name(bc) = sexp_c_string(ctx, sexp_opcode_name(op)); + res = sexp_make_procedure(ctx, sexp_make_integer(0), sexp_make_integer(i), + bc, SEXP_VOID); if (i == sexp_opcode_num_args(op)) sexp_opcode_proc(op) = res; return res; @@ -975,10 +995,10 @@ static sexp make_opcode_procedure (sexp op, sexp_uint_t i, sexp env, /*********************** the virtual machine **************************/ -static sexp sexp_save_stack(sexp *stack, sexp_uint_t to) { +static sexp sexp_save_stack(sexp ctx, sexp *stack, sexp_uint_t to) { sexp res, *data; sexp_uint_t i; - res = sexp_make_vector(sexp_make_integer(to), SEXP_VOID); + res = sexp_make_vector(ctx, sexp_make_integer(to), SEXP_VOID); data = sexp_vector_data(res); for (i=0; i 0) { if (sexp_procedure_variadic_p(tmp1)) { - stack[top-i-1] = sexp_cons(stack[top-i-1], SEXP_NULL); + stack[top-i-1] = sexp_cons(context, stack[top-i-1], SEXP_NULL); for (k=top-i; kinexact: not a number", sexp_list1(_ARG1)); + sexp_raise("exact->inexact: not a number", sexp_list1(context, _ARG1)); break; case OP_FLO2FIX: #if USE_FLONUMS @@ -1477,7 +1497,7 @@ sexp vm (sexp self, sexp context, sexp* stack, sexp_sint_t top) { else #endif if (! sexp_integerp(_ARG1)) - sexp_raise("inexact->exact: not a number", sexp_list1(_ARG1)); + sexp_raise("inexact->exact: not a number", sexp_list1(context, _ARG1)); break; case OP_CHAR2INT: _ARG1 = sexp_make_integer(sexp_unbox_character(_ARG1)); @@ -1523,7 +1543,7 @@ sexp vm (sexp self, sexp context, sexp* stack, sexp_sint_t top) { _ARG1 = SEXP_VOID; break; case OP_READ: - _ARG1 = sexp_read(_ARG1); + _ARG1 = sexp_read(context, _ARG1); sexp_check_exception(); break; case OP_READ_CHAR: @@ -1548,7 +1568,7 @@ sexp vm (sexp self, sexp context, sexp* stack, sexp_sint_t top) { case OP_DONE: goto end_loop; default: - sexp_raise("unknown opcode", sexp_list1(sexp_make_integer(*(ip-1)))); + sexp_raise("unknown opcode", sexp_list1(context, sexp_make_integer(*(ip-1)))); } goto loop; @@ -1558,32 +1578,33 @@ sexp vm (sexp self, sexp context, sexp* stack, sexp_sint_t top) { /************************ library procedures **************************/ -static sexp sexp_exception_type_func (sexp exn) { +static sexp sexp_exception_type_func (sexp ctx, sexp exn) { if (sexp_exceptionp(exn)) return sexp_exception_kind(exn); else - return sexp_type_exception("not an exception", exn); + return sexp_type_exception(ctx, "not an exception", exn); } -static sexp sexp_open_input_file (sexp path) { +static sexp sexp_open_input_file (sexp ctx, sexp path) { FILE *in; - if (! sexp_stringp(path)) return sexp_type_exception("not a string", path); + if (! sexp_stringp(path)) return sexp_type_exception(ctx, "not a string", path); in = fopen(sexp_string_data(path), "r"); if (! in) - return sexp_user_exception(SEXP_FALSE, "couldn't open input file", path); - return sexp_make_input_port(in, sexp_string_data(path)); + return sexp_user_exception(ctx, SEXP_FALSE, "couldn't open input file", path); + return sexp_make_input_port(ctx, in, sexp_string_data(path)); } -static sexp sexp_open_output_file (sexp path) { +static sexp sexp_open_output_file (sexp ctx, sexp path) { FILE *out; - if (! sexp_stringp(path)) return sexp_type_exception("not a string", path); + if (! sexp_stringp(path)) + return sexp_type_exception(ctx, "not a string", path); out = fopen(sexp_string_data(path), "w"); if (! out) - return sexp_user_exception(SEXP_FALSE, "couldn't open output file", path); - return sexp_make_input_port(out, sexp_string_data(path)); + return sexp_user_exception(ctx, SEXP_FALSE, "couldn't open output file", path); + return sexp_make_input_port(ctx, out, sexp_string_data(path)); } -static sexp sexp_close_port (sexp port) { +static sexp sexp_close_port (sexp ctx, sexp port) { fclose(sexp_port_stream(port)); return SEXP_VOID; } @@ -1598,25 +1619,25 @@ static void sexp_warn_undefs (sexp from, sexp to, sexp out) { } } -sexp sexp_load (sexp source, sexp env) { - sexp x, res, in, tmp, out, context = sexp_make_context(NULL, env); +sexp sexp_load (sexp ctx, sexp source, sexp env) { + sexp x, res, in, tmp, out, context = sexp_make_context(ctx, NULL, env); out = env_global_ref(env, the_cur_err_symbol, SEXP_FALSE); tmp = sexp_env_bindings(env); sexp_context_tailp(context) = 0; - in = sexp_open_input_file(source); + in = sexp_open_input_file(ctx, source); if (sexp_exceptionp(in)) { - sexp_print_exception(in, out); + sexp_print_exception(ctx, in, out); return in; } - while ((x=sexp_read(in)) != (sexp) SEXP_EOF) { + while ((x=sexp_read(ctx, in)) != (sexp) SEXP_EOF) { res = eval_in_context(x, context); if (sexp_exceptionp(res)) break; } if (x == SEXP_EOF) res = SEXP_VOID; - sexp_close_port(in); -#ifdef USE_WARN_UNDEFS + sexp_close_port(ctx, in); +#if USE_WARN_UNDEFS if (sexp_oportp(out)) sexp_warn_undefs(sexp_env_bindings(env), tmp, out); #endif @@ -1626,15 +1647,15 @@ sexp sexp_load (sexp source, sexp env) { #if USE_MATH #define define_math_op(name, cname) \ - static sexp name (sexp z) { \ + static sexp name (sexp ctx, sexp z) { \ double d; \ if (sexp_flonump(z)) \ d = sexp_flonum_value(z); \ else if (sexp_integerp(z)) \ d = (double)sexp_unbox_integer(z); \ else \ - return sexp_type_exception("not a number", z); \ - return sexp_make_flonum(cname(d)); \ + return sexp_type_exception(ctx, "not a number", z); \ + return sexp_make_flonum(ctx, cname(d)); \ } define_math_op(sexp_exp, exp) @@ -1653,7 +1674,7 @@ define_math_op(sexp_ceiling, ceil) #endif -static sexp sexp_expt (sexp x, sexp e) { +static sexp sexp_expt (sexp ctx, sexp x, sexp e) { double res, x1, e1; if (sexp_integerp(x)) x1 = (double)sexp_unbox_integer(x); @@ -1662,7 +1683,7 @@ static sexp sexp_expt (sexp x, sexp e) { x1 = sexp_flonum_value(x); #endif else - return sexp_type_exception("not a number", x); + return sexp_type_exception(ctx, "not a number", x); if (sexp_integerp(e)) e1 = (double)sexp_unbox_integer(e); #if USE_FLONUMS @@ -1670,25 +1691,25 @@ static sexp sexp_expt (sexp x, sexp e) { e1 = sexp_flonum_value(e); #endif else - return sexp_type_exception("not a number", e); + return sexp_type_exception(ctx, "not a number", e); res = pow(x1, e1); #if USE_FLONUMS if ((res > SEXP_MAX_INT) || sexp_flonump(x) || sexp_flonump(e)) - return sexp_make_flonum(res); + return sexp_make_flonum(ctx, res); #endif return sexp_make_integer((sexp_sint_t)round(res)); } -static sexp sexp_string_concatenate (sexp str_ls) { +static sexp sexp_string_concatenate (sexp ctx, sexp str_ls) { sexp res, ls; sexp_uint_t len=0; char *p; for (ls=str_ls; sexp_pairp(ls); ls=sexp_cdr(ls)) if (! sexp_stringp(sexp_car(ls))) - return sexp_type_exception("not a string", sexp_car(ls)); + return sexp_type_exception(ctx, "not a string", sexp_car(ls)); else len += sexp_string_length(sexp_car(ls)); - res = sexp_make_string(sexp_make_integer(len), SEXP_VOID); + res = sexp_make_string(ctx, sexp_make_integer(len), SEXP_VOID); p = sexp_string_data(res); for (ls=str_ls; sexp_pairp(ls); ls=sexp_cdr(ls)) { len = sexp_string_length(sexp_car(ls)); @@ -1698,31 +1719,19 @@ static sexp sexp_string_concatenate (sexp str_ls) { return res; } -static sexp sexp_string_cmp (sexp str1, sexp str2) { +static sexp sexp_string_cmp (sexp ctx, sexp str1, sexp str2, sexp ci) { sexp_sint_t len1, len2, len, diff; if (! sexp_stringp(str1)) - return sexp_type_exception("not a string", str1); + return sexp_type_exception(ctx, "not a string", str1); if (! sexp_stringp(str2)) - return sexp_type_exception("not a string", str2); + return sexp_type_exception(ctx, "not a string", str2); len1 = sexp_string_length(str1); len2 = sexp_string_length(str2); len = ((len1= size) { + if (sexp_unbox_integer(sexp_gc(ctx)) >= size) { goto try_alloc; } else { fprintf(stderr, "chibi: out of memory trying to allocate %ld bytes, aborting\n", size); @@ -41,7 +71,7 @@ void sexp_mark (sexp x) { loop: if ((! sexp_pointerp(x)) || sexp_mark(x)) return; - sexp_mark(x) = 1; + sexp_gc_mark(x) = 1; switch (sexp_tag(x)) { case SEXP_PAIR: sexp_mark(sexp_car(x)); @@ -56,9 +86,10 @@ void sexp_mark (sexp x) { sexp sexp_sweep () { sexp_uint_t freed=0, size; - sexp p=(sexp)sexp_heap, f=sexp_free_list; - /* XXXX make p skip over areas already in the free_list */ + sexp p=(sexp)sexp_heap, f1=sexp_free_list, f2; while (p? s1 s2) (> (string-cmp s1 s2) 0)) -(define (string>=? s1 s2) (>= (string-cmp s1 s2) 0)) +(define (string=? s1 s2) (eq? (string-cmp s1 s2 #f) 0)) +(define (string? s1 s2) (> (string-cmp s1 s2 #f) 0)) +(define (string>=? s1 s2) (>= (string-cmp s1 s2 #f) 0)) -(define (string-ci=? s1 s2) (eq? (string-cmp-ci s1 s2) 0)) -(define (string-ci? s1 s2) (> (string-cmp-ci s1 s2) 0)) -(define (string-ci>=? s1 s2) (>= (string-cmp-ci s1 s2) 0)) +(define (string-ci=? s1 s2) (eq? (string-cmp s1 s2 #t) 0)) +(define (string-ci? s1 s2) (> (string-cmp s1 s2 #t) 0)) +(define (string-ci>=? s1 s2) (>= (string-cmp s1 s2 #t) 0)) ;; list utils @@ -418,6 +422,8 @@ (define magnitude abs) (define (angle z) (if (< z 0) 3.141592653589793 0)) +(define (atan x . o) (if (null? o) (atan1 x) (atan1 (/ x (car o))))) + (define (digit-char n) (integer->char (+ n (char->integer #\0)))) (define (digit-value ch) (if (char-numeric? ch) diff --git a/main.c b/main.c index 62da5068..fd90e900 100644 --- a/main.c +++ b/main.c @@ -11,15 +11,15 @@ void repl (sexp context) { while (1) { sexp_write_string("> ", out); sexp_flush(out); - obj = sexp_read(in); + obj = sexp_read(context, in); if (obj == SEXP_EOF) break; if (sexp_exceptionp(obj)) { - sexp_print_exception(obj, err); + sexp_print_exception(context, obj, err); } else { tmp = sexp_env_bindings(env); res = eval_in_context(obj, context); -#ifdef USE_WARN_UNDEFS +#if USE_WARN_UNDEFS sexp_warn_undefs(sexp_env_bindings(env), tmp, err); #endif if (res != SEXP_VOID) { @@ -34,12 +34,13 @@ void run_main (int argc, char **argv) { sexp env, out=NULL, res, context, perr_cell, err_cell, err_handler; sexp_uint_t i, quit=0, init_loaded=0; - env = sexp_make_standard_env(sexp_make_integer(5)); - env_define(env, the_interaction_env_symbol, env); + context = sexp_make_context(NULL, NULL, NULL); + env = sexp_make_standard_env(context, sexp_make_integer(5)); + env_define(context, env, the_interaction_env_symbol, env); out = env_global_ref(env, the_cur_out_symbol, SEXP_FALSE); err_cell = env_cell(env, the_cur_err_symbol); - perr_cell = env_cell(env, sexp_intern("print-exception")); - context = sexp_make_context(NULL, env); + perr_cell = env_cell(env, sexp_intern(context, "print-exception")); + sexp_context_env(context) = env; sexp_context_tailp(context) = 0; if (err_cell && perr_cell && sexp_opcodep(sexp_cdr(perr_cell))) { emit(OP_GLOBAL_KNOWN_REF, context); @@ -51,11 +52,12 @@ void run_main (int argc, char **argv) { } emit_push(SEXP_VOID, context); emit(OP_DONE, context); - err_handler = sexp_make_procedure(sexp_make_integer(0), + err_handler = sexp_make_procedure(context, + sexp_make_integer(0), sexp_make_integer(0), finalize_bytecode(context), - sexp_make_vector(0, SEXP_VOID)); - env_define(env, the_err_handler_symbol, err_handler); + sexp_make_vector(context, 0, SEXP_VOID)); + env_define(context, env, the_err_handler_symbol, err_handler); /* parse options */ for (i=1; i < argc && argv[i][0] == '-'; i++) { @@ -64,12 +66,12 @@ void run_main (int argc, char **argv) { case 'e': case 'p': if (! init_loaded++) - sexp_load(sexp_c_string(sexp_init_file), env); - res = sexp_read_from_string(argv[i+1]); + sexp_load(context, sexp_c_string(context, sexp_init_file), env); + res = sexp_read_from_string(context, argv[i+1]); if (! sexp_exceptionp(res)) res = eval_in_context(res, context); if (sexp_exceptionp(res)) { - sexp_print_exception(res, out); + sexp_print_exception(context, res, out); } else if (argv[i][1] == 'p') { sexp_write(res, out); sexp_write_char('\n', out); @@ -80,8 +82,8 @@ void run_main (int argc, char **argv) { #endif case 'l': if (! init_loaded++) - sexp_load(sexp_c_string(sexp_init_file), env); - sexp_load(sexp_c_string(argv[++i]), env); + sexp_load(context, sexp_c_string(context, sexp_init_file), env); + sexp_load(context, sexp_c_string(context, argv[++i]), env); break; case 'q': init_loaded = 1; @@ -93,10 +95,10 @@ void run_main (int argc, char **argv) { if (! quit) { if (! init_loaded) - sexp_load(sexp_c_string(sexp_init_file), env); + sexp_load(context, sexp_c_string(context, sexp_init_file), env); if (i < argc) for ( ; i < argc; i++) - sexp_load(sexp_c_string(argv[i]), env); + sexp_load(context, sexp_c_string(context, argv[i]), env); else repl(context); } diff --git a/opcodes.c b/opcodes.c index 5bd6cc4a..0aee670c 100644 --- a/opcodes.c +++ b/opcodes.c @@ -77,6 +77,8 @@ _FN1(0, "identifier->symbol", 0, sexp_syntactic_closure_expr), _FN4(0, SEXP_ENV, "identifier=?", 0, sexp_identifier_eq), _FN1(SEXP_PAIR, "length", 0, sexp_length), _FN1(SEXP_PAIR, "reverse", 0, sexp_reverse), +_FN1(SEXP_PAIR, "reverse!", 0, sexp_nreverse), +_FN2(SEXP_PAIR, SEXP_PAIR, "append2", 0, sexp_append2), _FN1(SEXP_PAIR, "list->vector", 0, sexp_list_to_vector), _FN1(SEXP_STRING, "open-input-file", 0, sexp_open_input_file), _FN1(SEXP_STRING, "open-output-file", 0, sexp_open_output_file), @@ -89,8 +91,7 @@ _FN2(SEXP_EXCEPTION, SEXP_OPORT, "print-exception", 0, sexp_print_exception), _FN1(SEXP_EXCEPTION, "exception-type", 0, sexp_exception_type_func), _FN6(SEXP_SYMBOL, SEXP_STRING, "make-exception", 0, sexp_make_exception), _FN2OPT(SEXP_FIXNUM, SEXP_CHAR, "make-string", sexp_make_character(' '), sexp_make_string), -_FN2(SEXP_STRING, SEXP_STRING, "string-cmp", 0, sexp_string_cmp), -_FN2(SEXP_STRING, SEXP_STRING, "string-cmp-ci", 0, sexp_string_cmp_ci), +_FN3(SEXP_STRING, SEXP_STRING, "string-cmp", 0, sexp_string_cmp), _FN3(SEXP_STRING, SEXP_FIXNUM, "substring", 0, sexp_substring), _FN1(SEXP_STRING, "string->symbol", 0, sexp_string_to_symbol), _FN1(SEXP_PAIR, "string-concatenate", 0, sexp_string_concatenate), @@ -110,7 +111,7 @@ _FN1(0, "cos", 0, sexp_cos), _FN1(0, "tan", 0, sexp_tan), _FN1(0, "asin", 0, sexp_asin), _FN1(0, "acos", 0, sexp_acos), -_FN1(0, "atan", 0, sexp_atan), +_FN1(0, "atan1", 0, sexp_atan), _FN1(0, "sqrt", 0, sexp_sqrt), _FN1(0, "round", 0, sexp_round), _FN1(0, "truncate", 0, sexp_trunc), diff --git a/sexp.c b/sexp.c index f8b4a459..ee113fda 100644 --- a/sexp.c +++ b/sexp.c @@ -53,8 +53,8 @@ static int is_separator(int c) { static sexp symbol_table[SEXP_SYMBOL_TABLE_SIZE]; -sexp sexp_alloc_tagged(size_t size, sexp_uint_t tag) { - sexp res = (sexp) sexp_alloc(size); +sexp sexp_alloc_tagged(sexp ctx, size_t size, sexp_uint_t tag) { + sexp res = (sexp) sexp_alloc(ctx, size); if (! res) errx(EX_OSERR, "out of memory: couldn't allocate %ld bytes for %ld", size ,tag); @@ -63,7 +63,7 @@ sexp sexp_alloc_tagged(size_t size, sexp_uint_t tag) { } #if ! USE_BOEHM -void sexp_deep_free (sexp obj) { +void sexp_deep_free (sexp ctx, sexp obj) { int len, i; sexp *elts; if (sexp_pointerp(obj)) { @@ -77,23 +77,23 @@ void sexp_deep_free (sexp obj) { elts = sexp_vector_data(obj); for (i=0; i 0; len--) - if (sexp_equalp(v1[len], v2[len]) == SEXP_FALSE) + if (sexp_equalp(ctx, v1[len], v2[len]) == SEXP_FALSE) return SEXP_FALSE; return SEXP_TRUE; case SEXP_STRING: @@ -313,18 +311,18 @@ sexp sexp_equalp (sexp a, sexp b) { /********************* strings, symbols, vectors **********************/ -sexp sexp_make_flonum(double f) { - sexp x = sexp_alloc_type(flonum, SEXP_FLONUM); +sexp sexp_make_flonum(sexp ctx, double f) { + sexp x = sexp_alloc_type(ctx, flonum, SEXP_FLONUM); sexp_flonum_value(x) = f; return x; } -sexp sexp_make_string(sexp len, sexp ch) { +sexp sexp_make_string(sexp ctx, sexp len, sexp ch) { char *cstr; - sexp s = sexp_alloc_type(string, SEXP_STRING); + sexp s = sexp_alloc_type(ctx, string, SEXP_STRING); sexp_sint_t clen = sexp_unbox_integer(len); - if (clen < 0) return sexp_type_exception("negative length", len); - cstr = sexp_alloc(clen+1); + if (clen < 0) return sexp_type_exception(ctx, "negative length", len); + cstr = sexp_alloc(ctx, clen+1); if (sexp_charp(ch)) memset(cstr, sexp_unbox_character(ch), clen); cstr[clen] = '\0'; @@ -333,31 +331,30 @@ sexp sexp_make_string(sexp len, sexp ch) { return s; } -sexp sexp_c_string(char *str) { +sexp sexp_c_string(sexp ctx, char *str) { sexp_uint_t len = strlen(str); - sexp s = sexp_make_string(sexp_make_integer(len), SEXP_VOID); + sexp s = sexp_make_string(ctx, sexp_make_integer(len), SEXP_VOID); memcpy(sexp_string_data(s), str, len); return s; } -sexp sexp_substring (sexp str, sexp start, sexp end) { +sexp sexp_substring (sexp ctx, sexp str, sexp start, sexp end) { sexp res; if (! sexp_stringp(str)) - return sexp_type_exception("not a string", str); + return sexp_type_exception(ctx, "not a string", str); if (! sexp_integerp(start)) - return sexp_type_exception("not a number", start); + return sexp_type_exception(ctx, "not a number", start); if (end == SEXP_FALSE) end = sexp_make_integer(sexp_string_length(str)); if (! sexp_integerp(end)) - return sexp_type_exception("not a number", end); + return sexp_type_exception(ctx, "not a number", end); if ((sexp_unbox_integer(start) < 0) || (sexp_unbox_integer(start) > sexp_string_length(str)) || (sexp_unbox_integer(end) < 0) || (sexp_unbox_integer(end) > sexp_string_length(str)) || (end < start)) - return sexp_range_exception(str, start, end); - res = sexp_make_string(sexp_fx_sub(end, start), - SEXP_VOID); + return sexp_range_exception(ctx, str, start, end); + res = sexp_make_string(ctx, sexp_fx_sub(end, start), SEXP_VOID); memcpy(sexp_string_data(res), sexp_string_data(str)+sexp_unbox_integer(start), sexp_string_length(res)); @@ -372,7 +369,7 @@ sexp_uint_t sexp_string_hash(char *str, sexp_uint_t acc) { return acc; } -sexp sexp_intern(char *str) { +sexp sexp_intern(sexp ctx, char *str) { struct huff_entry he; sexp_uint_t len, res=FNV_OFFSET_BASIS, space=3, newbits, bucket; char c, *mystr, *p=str; @@ -404,26 +401,26 @@ sexp sexp_intern(char *str) { return sexp_car(ls); /* not found, make a new symbol */ - sym = sexp_alloc_type(symbol, SEXP_SYMBOL); - mystr = sexp_alloc(len+1); + sym = sexp_alloc_type(ctx, symbol, SEXP_SYMBOL); + mystr = sexp_alloc(ctx, len+1); memcpy(mystr, str, len+1); mystr[len]=0; sexp_symbol_length(sym) = len; sexp_symbol_data(sym) = mystr; - sexp_push(symbol_table[bucket], sym); + sexp_push(ctx, symbol_table[bucket], sym); return sym; } -sexp sexp_string_to_symbol (sexp str) { - return sexp_intern(sexp_string_data(str)); +sexp sexp_string_to_symbol (sexp ctx, sexp str) { + return sexp_intern(ctx, sexp_string_data(str)); } -sexp sexp_make_vector(sexp len, sexp dflt) { +sexp sexp_make_vector(sexp ctx, 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)); + v = sexp_alloc_type(ctx, vector, SEXP_VECTOR); + x = (sexp*) sexp_alloc(ctx, clen*sizeof(sexp)); for (i=0; i= len) { - newbuf = sexp_make_string(sexp_make_integer(newpos*2), SEXP_VOID); + newbuf = sexp_make_string(NULL, sexp_make_integer(newpos*2), SEXP_VOID); memcpy(sexp_string_data(newbuf), sexp_string_data(sexp_stream_buf(vec)), pos); @@ -507,54 +504,55 @@ off_t sstream_seek (void *vec, off_t offset, int whence) { return pos; } -sexp sexp_make_input_string_port (sexp str) { +sexp sexp_make_input_string_port (sexp ctx, sexp str) { FILE *in; sexp res, cookie; - cookie = sexp_vector(3, str, sexp_make_integer(sexp_string_length(str)), + cookie = sexp_vector(ctx, 3, str, sexp_make_integer(sexp_string_length(str)), sexp_make_integer(0)); in = funopen(cookie, &sstream_read, NULL, &sstream_seek, NULL); - res = sexp_make_input_port(in, NULL); + res = sexp_make_input_port(ctx, in, NULL); sexp_port_cookie(res) = cookie; return res; } -sexp sexp_make_output_string_port () { +sexp sexp_make_output_string_port (sexp ctx) { FILE *out; sexp res, size, cookie; size = sexp_make_integer(SEXP_INIT_STRING_PORT_SIZE); - cookie = sexp_vector(3, sexp_make_string(size, SEXP_VOID), + cookie = sexp_vector(ctx, 3, sexp_make_string(NULL, size, SEXP_VOID), size, sexp_make_integer(0)); out = funopen(cookie, NULL, &sstream_write, &sstream_seek, NULL); - res = sexp_make_output_port(out, NULL); + res = sexp_make_output_port(ctx, out, NULL); sexp_port_cookie(res) = cookie; return res; } -sexp sexp_get_output_string (sexp port) { +sexp sexp_get_output_string (sexp ctx, sexp port) { sexp cookie = sexp_port_cookie(port); fflush(sexp_port_stream(port)); - return sexp_substring(sexp_stream_buf(cookie), + return sexp_substring(ctx, + sexp_stream_buf(cookie), sexp_make_integer(0), sexp_stream_pos(cookie)); } #else -sexp sexp_make_input_string_port (sexp str) { +sexp sexp_make_input_string_port (sexp ctx, sexp str) { FILE *in = fmemopen(sexp_string_data(str), sexp_string_length(str), "r"); return sexp_make_input_port(in, NULL); } -sexp sexp_make_output_string_port () { +sexp sexp_make_output_string_port (sexp ctx) { FILE *out; - sexp buf = sexp_alloc_type(string, SEXP_STRING), res; + sexp buf = sexp_alloc_type(ctx, string, SEXP_STRING), res; out = open_memstream(&sexp_string_data(buf), &sexp_string_length(buf)); res = sexp_make_input_port(out, NULL); sexp_port_cookie(res) = buf; return res; } -sexp sexp_get_output_string (sexp port) { +sexp sexp_get_output_string (sexp ctx, sexp port) { sexp cookie = sexp_port_cookie(port); fflush(sexp_port_stream(port)); return sexp_substring(cookie, @@ -566,16 +564,16 @@ sexp sexp_get_output_string (sexp port) { #endif -sexp sexp_make_input_port (FILE* in, char *path) { - sexp p = sexp_alloc_type(port, SEXP_IPORT); +sexp sexp_make_input_port (sexp ctx, FILE* in, char *path) { + sexp p = sexp_alloc_type(ctx, port, SEXP_IPORT); sexp_port_stream(p) = in; sexp_port_name(p) = path; sexp_port_line(p) = 0; return p; } -sexp sexp_make_output_port (FILE* out, char *path) { - sexp p = sexp_alloc_type(port, SEXP_OPORT); +sexp sexp_make_output_port (sexp ctx, FILE* out, char *path) { + sexp p = sexp_alloc_type(ctx, port, SEXP_OPORT); sexp_port_stream(p) = out; sexp_port_name(p) = path; sexp_port_line(p) = 0; @@ -761,15 +759,15 @@ void sexp_write (sexp obj, sexp out) { } } -char* sexp_read_string(sexp in) { +char* sexp_read_string(sexp ctx, sexp in) { char *buf, *tmp, *res; int c, i=0, size=128; - buf = sexp_alloc(size); + buf = sexp_alloc(ctx, size); for (c=sexp_read_char(in); c != '"'; c=sexp_read_char(in)) { if (c == EOF) { - sexp_free(buf); + sexp_free(ctx, buf); return NULL; } if (c == '\\') { @@ -783,25 +781,25 @@ char* sexp_read_string(sexp in) { buf[i++] = c; } if (i >= size) { - tmp = sexp_alloc(2*size); + tmp = sexp_alloc(ctx, 2*size); memcpy(tmp, buf, i); - sexp_free(buf); + sexp_free(ctx, buf); buf = tmp; } } buf[i] = '\0'; - res = sexp_alloc(i); + res = sexp_alloc(ctx, i); memcpy(res, buf, i); - sexp_free(buf); + sexp_free(ctx, buf); return res; } -char* sexp_read_symbol(sexp in, int init) { +char* sexp_read_symbol(sexp ctx, sexp in, int init) { char *buf, *tmp, *res; int c, i=0, size=128; - buf = sexp_alloc(size); + buf = sexp_alloc(ctx, size); if (init != EOF) buf[i++] = init; @@ -814,21 +812,21 @@ char* sexp_read_symbol(sexp in, int init) { } buf[i++] = c; if (i >= size) { - tmp = sexp_alloc(2*size); + tmp = sexp_alloc(ctx, 2*size); memcpy(tmp, buf, i); - sexp_free(buf); + sexp_free(ctx, buf); buf = tmp; } } buf[i] = '\0'; - res = sexp_alloc(i); + res = sexp_alloc(ctx, i); memcpy(res, buf, i); - sexp_free(buf); + sexp_free(ctx, buf); return res; } -sexp sexp_read_float_tail(sexp in, sexp_sint_t whole) { +sexp sexp_read_float_tail(sexp ctx, sexp in, sexp_sint_t whole) { sexp exponent; double res=0.0, scale=0.1, e=0.0; int c; @@ -836,17 +834,17 @@ sexp sexp_read_float_tail(sexp in, sexp_sint_t whole) { res += digit_value(c)*scale; sexp_push_char(c, in); if (c=='e' || c=='E') { - exponent = sexp_read_number(in, 10); + exponent = sexp_read_number(ctx, in, 10); if (sexp_exceptionp(exponent)) return exponent; e = (sexp_integerp(exponent) ? sexp_unbox_integer(exponent) : sexp_flonump(exponent) ? sexp_flonum_value(exponent) : 0.0); } else if ((c!=EOF) && ! is_separator(c)) - return sexp_read_error("invalid numeric syntax", - sexp_list1(sexp_make_character(c)), in); - return sexp_make_flonum((whole + res) * pow(10, e)); + return sexp_read_error(ctx, "invalid numeric syntax", + sexp_list1(ctx, sexp_make_character(c)), in); + return sexp_make_flonum(ctx, (whole + res) * pow(10, e)); } -sexp sexp_read_number(sexp in, int base) { +sexp sexp_read_number(sexp ctx, sexp in, int base) { sexp f; sexp_sint_t res = 0, negativep = 0, c; @@ -864,10 +862,10 @@ sexp sexp_read_number(sexp in, int base) { if (c=='.' || c=='e' || c=='E') { if (base != 10) - return sexp_read_error("decimal found in non-base 10", SEXP_NULL, in); + return sexp_read_error(ctx, "decimal found in non-base 10", SEXP_NULL, in); if (c!='.') sexp_push_char(c, in); - f = sexp_read_float_tail(in, res); + f = sexp_read_float_tail(ctx, in, res); if (! sexp_flonump(f)) return f; if ((c!='.') && (sexp_flonum_value(f) == round(sexp_flonum_value(f)))) { res = (sexp_sint_t) sexp_flonum_value(f); @@ -878,14 +876,14 @@ sexp sexp_read_number(sexp in, int base) { } else { sexp_push_char(c, in); if ((c!=EOF) && ! is_separator(c)) - return sexp_read_error("invalid numeric syntax", - sexp_list1(sexp_make_character(c)), in); + return sexp_read_error(ctx, "invalid numeric syntax", + sexp_list1(ctx, sexp_make_character(c)), in); } return sexp_make_integer(negativep ? -res : res); } -sexp sexp_read_raw (sexp in) { +sexp sexp_read_raw (sexp ctx, sexp in) { sexp res, tmp, tmp2; char *str; int c1, c2; @@ -909,82 +907,82 @@ sexp sexp_read_raw (sexp in) { sexp_port_line(in)++; goto scan_loop; case '\'': - res = sexp_read(in); - res = sexp_list2(the_quote_symbol, res); + res = sexp_read(ctx, in); + res = sexp_list2(ctx, the_quote_symbol, res); break; case '`': - res = sexp_read(in); - res = sexp_list2(the_quasiquote_symbol, res); + res = sexp_read(ctx, in); + res = sexp_list2(ctx, the_quasiquote_symbol, res); break; case ',': if ((c1 = sexp_read_char(in)) == '@') { - res = sexp_read(in); - res = sexp_list2(the_unquote_splicing_symbol, res); + res = sexp_read(ctx, in); + res = sexp_list2(ctx, the_unquote_splicing_symbol, res); } else { sexp_push_char(c1, in); - res = sexp_read(in); - res = sexp_list2(the_unquote_symbol, res); + res = sexp_read(ctx, in); + res = sexp_list2(ctx, the_unquote_symbol, res); } break; case '"': - str = sexp_read_string(in); + str = sexp_read_string(ctx, in); if (! str) - res = sexp_read_error("premature end of string", SEXP_NULL, in); + res = sexp_read_error(ctx, "premature end of string", SEXP_NULL, in); else - res = sexp_c_string(str); - sexp_free(str); + res = sexp_c_string(ctx, str); + sexp_free(ctx, str); break; case '(': res = SEXP_NULL; - tmp = sexp_read_raw(in); + tmp = sexp_read_raw(ctx, 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", + return sexp_read_error(ctx, "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", + tmp = sexp_read_raw(ctx, in); + if (sexp_read_raw(ctx, in) != SEXP_CLOSE) { + sexp_deep_free(ctx, res); + return sexp_read_error(ctx, "multiple tokens in dotted tail", SEXP_NULL, in); } else { tmp2 = res; - res = sexp_nreverse(res); + res = sexp_nreverse(ctx, res); sexp_cdr(tmp2) = tmp; return res; } } } else { - res = sexp_cons(tmp, res); - tmp = sexp_read_raw(in); + res = sexp_cons(ctx, tmp, res); + tmp = sexp_read_raw(ctx, in); } } if (tmp != SEXP_CLOSE) { - sexp_deep_free(res); - return sexp_read_error("missing trailing ')'", SEXP_NULL, in); + sexp_deep_free(ctx, res); + return sexp_read_error(ctx, "missing trailing ')'", SEXP_NULL, in); } - res = (sexp_pairp(res) ? sexp_nreverse(res) : res); + res = (sexp_pairp(res) ? sexp_nreverse(ctx, res) : res); break; case '#': switch (c1=sexp_read_char(in)) { case 'b': - res = sexp_read_number(in, 2); break; + res = sexp_read_number(ctx, in, 2); break; case 'o': - res = sexp_read_number(in, 8); break; + res = sexp_read_number(ctx, in, 8); break; case 'd': - res = sexp_read_number(in, 10); break; + res = sexp_read_number(ctx, in, 10); break; case 'x': - res = sexp_read_number(in, 16); break; + res = sexp_read_number(ctx, in, 16); break; case 'e': - res = sexp_read(in); + res = sexp_read(ctx, in); if (sexp_flonump(res)) res = sexp_make_integer((sexp_sint_t)sexp_flonum_value(res)); break; case 'i': - res = sexp_read(in); + res = sexp_read(ctx, in); if (sexp_integerp(res)) - res = sexp_make_flonum(sexp_unbox_integer(res)); + res = sexp_make_flonum(ctx, sexp_unbox_integer(res)); break; case 'f': case 't': @@ -993,21 +991,22 @@ sexp sexp_read_raw (sexp in) { res = (c1 == 't' ? SEXP_TRUE : SEXP_FALSE); sexp_push_char(c2, in); } else { - res = sexp_read_error("invalid syntax #%c%c", - sexp_list2(sexp_make_character(c1), + res = sexp_read_error(ctx, "invalid syntax #%c%c", + sexp_list2(ctx, + sexp_make_character(c1), sexp_make_character(c2)), in); } break; case ';': - sexp_read_raw(in); + sexp_read_raw(ctx, in); goto scan_loop; case '\\': c1 = sexp_read_char(in); - str = sexp_read_symbol(in, c1); + str = sexp_read_symbol(ctx, in, c1); if (str[0] == '\0') res = - sexp_read_error("unexpected end of character literal", SEXP_NULL, in); + sexp_read_error(ctx, "unexpected end of character literal", SEXP_NULL, in); if (str[1] == '\0') { res = sexp_make_character(c1); } else if ((c1 == 'x' || c1 == 'X') && @@ -1023,30 +1022,30 @@ sexp sexp_read_raw (sexp in) { else if (strcasecmp(str, "tab") == 0) res = sexp_make_character('\t'); else { - res = sexp_read_error("unknown character name", - sexp_list1(sexp_c_string(str)), + res = sexp_read_error(ctx, "unknown character name", + sexp_list1(ctx, sexp_c_string(ctx, str)), in); } } - sexp_free(str); + sexp_free(ctx, str); break; case '(': sexp_push_char(c1, in); - res = sexp_read(in); - if (sexp_listp(res) == SEXP_FALSE) { + res = sexp_read(ctx, in); + if (sexp_listp(ctx, res) == SEXP_FALSE) { if (! sexp_exceptionp(res)) { - sexp_deep_free(res); - res = sexp_read_error("dotted list not allowed in vector syntax", + sexp_deep_free(ctx, res); + res = sexp_read_error(ctx, "dotted list not allowed in vector syntax", SEXP_NULL, in); } } else { - res = sexp_list_to_vector(res); + res = sexp_list_to_vector(ctx, res); } break; default: - res = sexp_read_error("invalid # syntax", - sexp_list1(sexp_make_character(c1)), in); + res = sexp_read_error(ctx, "invalid # syntax", + sexp_list1(ctx, sexp_make_character(c1)), in); } break; case '.': @@ -1055,12 +1054,12 @@ sexp sexp_read_raw (sexp in) { res = SEXP_RAWDOT; } else if (isdigit(c1)) { sexp_push_char(c1,in ); - res = sexp_read_float_tail(in, 0); + res = sexp_read_float_tail(ctx, in, 0); } else { sexp_push_char(c1, in); - str = sexp_read_symbol(in, '.'); - res = sexp_intern(str); - sexp_free(str); + str = sexp_read_symbol(ctx, in, '.'); + res = sexp_intern(ctx, str); + sexp_free(ctx, str); } break; case ')': @@ -1071,7 +1070,7 @@ sexp sexp_read_raw (sexp in) { c2 = sexp_read_char(in); if (c2 == '.' || isdigit(c2)) { sexp_push_char(c2, in); - res = sexp_read_number(in, 10); + res = sexp_read_number(ctx, in, 10); if (sexp_exceptionp(res)) return res; if (c1 == '-') { #ifdef USE_FLONUMS @@ -1083,47 +1082,48 @@ sexp sexp_read_raw (sexp in) { } } else { sexp_push_char(c2, in); - str = sexp_read_symbol(in, c1); - res = sexp_intern(str); - sexp_free(str); + str = sexp_read_symbol(ctx, in, c1); + res = sexp_intern(ctx, str); + sexp_free(ctx, 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); + res = sexp_read_number(ctx, in, 10); break; default: - str = sexp_read_symbol(in, c1); - res = sexp_intern(str); - sexp_free(str); + str = sexp_read_symbol(ctx, in, c1); + res = sexp_intern(ctx, str); + sexp_free(ctx, str); break; } return res; } -sexp sexp_read (sexp in) { - sexp res = sexp_read_raw(in); +sexp sexp_read (sexp ctx, sexp in) { + sexp res = sexp_read_raw(ctx, in); if (res == SEXP_CLOSE) - return sexp_read_error("too many ')'s", SEXP_NULL, in); + return sexp_read_error(ctx, "too many ')'s", SEXP_NULL, in); if (res == SEXP_RAWDOT) - return sexp_read_error("unexpected '.'", SEXP_NULL, in); + return sexp_read_error(ctx, "unexpected '.'", SEXP_NULL, in); return res; } #if USE_STRING_STREAMS -sexp sexp_read_from_string(char *str) { - sexp s = sexp_c_string(str); - sexp in = sexp_make_input_string_port(s); - sexp res = sexp_read(in); - sexp_deep_free(s); - sexp_deep_free(in); +sexp sexp_read_from_string(sexp ctx, char *str) { + sexp s = sexp_c_string(ctx, str); + sexp in = sexp_make_input_string_port(ctx, s); + sexp res = sexp_read(ctx, in); + sexp_free(ctx, s); + sexp_deep_free(ctx, in); return res; } #endif void sexp_init() { int i; + sexp ctx; if (! sexp_initialized_p) { sexp_initialized_p = 1; #if USE_BOEHM @@ -1133,13 +1133,14 @@ void sexp_init() { #endif for (i=0; ivalue.x)) -#define sexp_alloc_type(type, tag) sexp_alloc_tagged(sexp_sizeof(type), tag) +#define sexp_alloc_type(ctx, type, tag) sexp_alloc_tagged(ctx, sexp_sizeof(type), tag) #define SEXP_MAKE_IMMEDIATE(n) ((sexp) ((n<value.flonum) #if USE_FLONUMS -#define sexp_integer_to_flonum(x) (sexp_make_flonum(sexp_unbox_integer(x))) +#define sexp_integer_to_flonum(ctx, x) (sexp_make_flonum(ctx, sexp_unbox_integer(x))) #else -#define sexp_integer_to_flonum(x) (x) +#define sexp_integer_to_flonum(ctx, x) (x) #endif /*************************** field accessors **************************/ @@ -357,20 +357,20 @@ struct sexp_struct { #define sexp_fx_rem(a, b) (sexp_make_integer(sexp_unbox_integer(a) % sexp_unbox_integer(b))) #define sexp_fx_sign(a) (-((sexp_sint_t)(a) < 0)) /* -1 or 0 */ -#define sexp_fp_add(a, b) (sexp_make_flonum(sexp_flonum_value(a) + sexp_flonum_value(b))) -#define sexp_fp_sub(a, b) (sexp_make_flonum(sexp_flonum_value(a) - sexp_flonum_value(b))) -#define sexp_fp_mul(a, b) (sexp_make_flonum(sexp_flonum_value(a) * sexp_flonum_value(b))) -#define sexp_fp_div(a, b) (sexp_make_flonum(sexp_flonum_value(a) / sexp_flonum_value(b))) +#define sexp_fp_add(x,a,b) (sexp_make_flonum(x, sexp_flonum_value(a) + sexp_flonum_value(b))) +#define sexp_fp_sub(x,a,b) (sexp_make_flonum(x, sexp_flonum_value(a) - sexp_flonum_value(b))) +#define sexp_fp_mul(x,a,b) (sexp_make_flonum(x, sexp_flonum_value(a) * sexp_flonum_value(b))) +#define sexp_fp_div(x,a,b) (sexp_make_flonum(x, sexp_flonum_value(a) / sexp_flonum_value(b))) /****************************** utilities *****************************/ -#define sexp_list1(a) sexp_cons(a, SEXP_NULL) -#define sexp_list2(a, b) sexp_cons(a, sexp_cons(b, SEXP_NULL)) -#define sexp_list3(a, b, c) sexp_cons(a, sexp_cons(b, sexp_cons(c, SEXP_NULL))) -#define sexp_list4(a, b, c, d) sexp_cons(a, sexp_cons(b, sexp_cons(c, sexp_cons(d, SEXP_NULL)))) +#define sexp_list1(x,a) sexp_cons((x), (a), SEXP_NULL) +#define sexp_list2(x,a,b) sexp_cons((x), (a), sexp_cons((x), (b), SEXP_NULL)) +#define sexp_list3(x,a,b,c) sexp_cons((x), (a), sexp_cons((x), (b), sexp_cons((x), (c), SEXP_NULL))) +#define sexp_list4(x,a,b,c,d) sexp_cons((x), (a), sexp_cons((x), (b), sexp_cons((x), (c), sexp_cons((x), (d), SEXP_NULL)))) -#define sexp_push(ls, x) ((ls) = sexp_cons((x), (ls))) -#define sexp_insert(ls, x) ((sexp_memq((x), (ls)) != SEXP_FALSE) ? (ls) : sexp_push((ls), (x))) +#define sexp_push(ctx, ls, x) ((ls) = sexp_cons((ctx), (x), (ls))) +#define sexp_insert(ctx, ls, x) ((sexp_memq(NULL, (x), (ls)) != SEXP_FALSE) ? (ls) : sexp_push((ctx), (ls), (x))) #define sexp_car(x) ((x)->value.pair.car) #define sexp_cdr(x) ((x)->value.pair.cdr) @@ -400,43 +400,43 @@ struct sexp_struct { #define sexp_scanf(p, ...) (fscanf(sexp_port_stream(p), __VA_ARGS__)) #define sexp_flush(p) (fflush(sexp_port_stream(p))) -sexp sexp_alloc_tagged(size_t size, sexp_uint_t tag); -sexp sexp_cons(sexp head, sexp tail); -sexp sexp_equalp (sexp a, sexp b); -sexp sexp_listp(sexp obj); -sexp sexp_reverse(sexp ls); -sexp sexp_nreverse(sexp ls); -sexp sexp_append(sexp a, sexp b); -sexp sexp_memq(sexp x, sexp ls); -sexp sexp_assq(sexp x, sexp ls); -sexp sexp_length(sexp ls); -sexp sexp_c_string(char *str); -sexp sexp_make_string(sexp len, sexp ch); -sexp sexp_substring (sexp str, sexp start, sexp end); -sexp sexp_make_flonum(double f); +sexp sexp_alloc_tagged(sexp ctx, size_t size, sexp_uint_t tag); +sexp sexp_cons(sexp ctx, sexp head, sexp tail); +sexp sexp_equalp (sexp ctx, sexp a, sexp b); +sexp sexp_listp(sexp ctx, sexp obj); +sexp sexp_reverse(sexp ctx, sexp ls); +sexp sexp_nreverse(sexp ctx, sexp ls); +sexp sexp_append2(sexp ctx, sexp a, sexp b); +sexp sexp_memq(sexp ctx, sexp x, sexp ls); +sexp sexp_assq(sexp ctx, sexp x, sexp ls); +sexp sexp_length(sexp ctx, sexp ls); +sexp sexp_c_string(sexp ctx, char *str); +sexp sexp_make_string(sexp ctx, sexp len, sexp ch); +sexp sexp_substring (sexp ctx, sexp str, sexp start, sexp end); +sexp sexp_make_flonum(sexp ctx, double f); sexp_uint_t sexp_string_hash(char *str, sexp_uint_t acc); -sexp sexp_intern(char *str); -sexp sexp_string_to_symbol(sexp str); -sexp sexp_make_vector(sexp len, sexp dflt); -sexp sexp_list_to_vector(sexp ls); -sexp sexp_vector(int count, ...); +sexp sexp_intern(sexp ctx, char *str); +sexp sexp_string_to_symbol(sexp ctx, sexp str); +sexp sexp_make_vector(sexp ctx, sexp len, sexp dflt); +sexp sexp_list_to_vector(sexp ctx, sexp ls); +sexp sexp_vector(sexp ctx, int count, ...); void sexp_write(sexp obj, sexp out); -char* sexp_read_string(sexp in); -char* sexp_read_symbol(sexp in, int init); -sexp sexp_read_number(sexp in, int base); -sexp sexp_read_raw(sexp in); -sexp sexp_read(sexp in); -sexp sexp_read_from_string(char *str); -sexp sexp_make_input_port(FILE* in, char *path); -sexp sexp_make_output_port(FILE* out, char *path); -sexp sexp_make_input_string_port(sexp str); -sexp sexp_make_output_string_port(); -sexp sexp_get_output_string(sexp port); -sexp sexp_make_exception(sexp kind, sexp message, sexp irritants, sexp procedure, sexp file, sexp line); -sexp sexp_user_exception (sexp self, char *message, sexp obj); -sexp sexp_type_exception (char *message, sexp obj); -sexp sexp_range_exception (sexp obj, sexp start, sexp end); -sexp sexp_print_exception(sexp exn, sexp out); +char* sexp_read_string(sexp ctx, sexp in); +char* sexp_read_symbol(sexp ctx, sexp in, int init); +sexp sexp_read_number(sexp ctx, sexp in, int base); +sexp sexp_read_raw(sexp ctx, sexp in); +sexp sexp_read(sexp ctx, sexp in); +sexp sexp_read_from_string(sexp ctx, char *str); +sexp sexp_make_input_port(sexp ctx, FILE* in, char *path); +sexp sexp_make_output_port(sexp ctx, FILE* out, char *path); +sexp sexp_make_input_string_port(sexp ctx, sexp str); +sexp sexp_make_output_string_port(sexp ctx); +sexp sexp_get_output_string(sexp ctx, sexp port); +sexp sexp_make_exception(sexp ctx, sexp kind, sexp message, sexp irritants, sexp procedure, sexp file, sexp line); +sexp sexp_user_exception (sexp ctx, sexp self, char *message, sexp obj); +sexp sexp_type_exception (sexp ctx, char *message, sexp obj); +sexp sexp_range_exception (sexp ctx, sexp obj, sexp start, sexp end); +sexp sexp_print_exception(sexp ctx, sexp exn, sexp out); void sexp_init(); #endif /* ! SEXP_H */ From 89d282ef9d6f503683a7c42ec0fce6949c9775df Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 5 May 2009 15:15:50 +0900 Subject: [PATCH 107/154] gc allocation working, need to fix garbage collecting --- Makefile | 7 ++-- defaults.h | 23 +----------- gc.c | 103 +++++++++++++++++++++++++++++------------------------ sexp.c | 10 ++++-- sexp.h | 30 ++++++++++++++++ 5 files changed, 100 insertions(+), 73 deletions(-) diff --git a/Makefile b/Makefile index d23dd575..fe8e381a 100644 --- a/Makefile +++ b/Makefile @@ -14,7 +14,8 @@ LDFLAGS=-lm # -Oz for smaller size on darwin CFLAGS=-Wall -g -Os -save-temps -GC_OBJ=./gc/gc.a +#GC_OBJ=./gc/gc.a +GC_OBJ= ./gc/gc.a: ./gc/alloc.c cd gc && make @@ -38,7 +39,7 @@ cleaner: clean rm -f chibi-scheme rm -rf *.dSYM -test: chibi-scheme +test-basic: chibi-scheme @for f in tests/basic/*.scm; do \ ./chibi-scheme $$f >$${f%.scm}.out 2>$${f%.scm}.err; \ if diff -q $${f%.scm}.out $${f%.scm}.res; then \ @@ -47,6 +48,8 @@ test: chibi-scheme echo "[FAIL] $${f%.scm}"; \ fi; \ done + +test: chibi-scheme ./chibi-scheme -l syntax-rules.scm tests/r5rs-tests.scm # install: chibi-scheme diff --git a/defaults.h b/defaults.h index 2367f68f..ad53a516 100644 --- a/defaults.h +++ b/defaults.h @@ -17,7 +17,7 @@ #endif #ifndef USE_BOEHM -#define USE_BOEHM 1 +#define USE_BOEHM 0 #endif #ifndef USE_MALLOC @@ -60,24 +60,3 @@ #define USE_CHECK_STACK 0 #endif -#if USE_BOEHM -#include "gc/include/gc.h" -#define sexp_alloc(ctx, size) GC_malloc(size) -#define sexp_alloc_atomic(ctx, size) GC_malloc_atomic(size) -#define sexp_realloc(ctx, x, size) GC_realloc(x, size) -#define sexp_free(ctx, x) -#define sexp_deep_free(ctx, x) -#elif USE_MALLOC -#define sexp_alloc(ctx, size) malloc(size) -#define sexp_alloc_atomic(ctx, size) malloc(size) -#define sexp_realloc(ctx, x, size) realloc(x, size) -#define sexp_free(ctx, x) free(x) -void sexp_deep_free(sexp ctx, sexp obj); -#else /* native gc */ -void *sexp_alloc(sexp ctx, size_t size); -#define sexp_alloc_atomic sexp_alloc -void *sexp_realloc(sexp ctx, sexp x, size_t size); -#define sexp_free(ctx, x) -#define sexp_deep_free(ctx, x) -#endif - diff --git a/gc.c b/gc.c index f6f7a537..8e9856b1 100644 --- a/gc.c +++ b/gc.c @@ -2,9 +2,9 @@ /* Copyright (c) 2009 Alex Shinn. All rights reserved. */ /* BSD-style license: http://synthcode.com/license.txt */ -#include +#include "sexp.h" -#define SEXP_INITIAL_HEAP_SIZE 10000000 +#define SEXP_INITIAL_HEAP_SIZE 100000000 #define SEXP_MINIMUM_OBJECT_SIZE (sexp_sizeof(flonum)) static char* sexp_heap; @@ -12,7 +12,7 @@ static char* sexp_heap_end; static sexp sexp_free_list; sexp_uint_t sexp_allocated_bytes (sexp x) { - switch (sexp_tag(x)) { + switch (sexp_pointer_tag(x)) { case SEXP_PAIR: return sexp_sizeof(pair); case SEXP_SYMBOL: return sexp_sizeof(symbol); case SEXP_STRING: return sexp_sizeof(string)+sexp_string_length(x); @@ -41,38 +41,14 @@ sexp_uint_t sexp_allocated_bytes (sexp x) { } } -void *sexp_alloc (sexp ctx, size_t size) { - sexp ls1, ls2, ls3; - try_alloc: - ls1=sexp_free_list; - for (ls2=sexp_cdr(ls1); sexp_pairp(ls2); ls1=ls2, ls2=sexp_cdr(ls2)) - if (sexp_car(ls2) >= size) { - if (sexp_car(ls2) >= size + SEXP_MINIMUM_OBJECT_SIZE) { - ls3 = (sexp) (((char*)ls2)+size); - sexp_car(ls3) = (sexp) (sexp_car(ls2) - size); - sexp_cdr(ls3) = sexp_cdr(ls2); - sexp_cdr(ls1) = sexp_cdr(ls3); - } else { - sexp_cdr(ls1) = sexp_cdr(ls2); - } - return ls2; - } - if (sexp_unbox_integer(sexp_gc(ctx)) >= size) { - goto try_alloc; - } else { - fprintf(stderr, "chibi: out of memory trying to allocate %ld bytes, aborting\n", size); - exit(70); - } -} - void sexp_mark (sexp x) { sexp *data; sexp_uint_t i; loop: - if ((! sexp_pointerp(x)) || sexp_mark(x)) + if ((! sexp_pointerp(x)) || sexp_gc_mark(x)) return; sexp_gc_mark(x) = 1; - switch (sexp_tag(x)) { + switch (sexp_pointer_tag(x)) { case SEXP_PAIR: sexp_mark(sexp_car(x)); x = sexp_cdr(x); @@ -87,42 +63,75 @@ void sexp_mark (sexp x) { sexp sexp_sweep () { sexp_uint_t freed=0, size; sexp p=(sexp)sexp_heap, f1=sexp_free_list, f2; - while (p= size) { + if ((sexp_uint_t)sexp_car(ls2) >= size + SEXP_MINIMUM_OBJECT_SIZE) { + ls3 = (sexp) (((char*)ls2)+size); + sexp_pointer_tag(ls3) = SEXP_PAIR; + sexp_car(ls3) = (sexp) (((sexp_uint_t)sexp_car(ls2)) - size); + sexp_cdr(ls3) = sexp_cdr(ls2); + sexp_cdr(ls1) = ls3; + } else { + sexp_cdr(ls1) = sexp_cdr(ls2); + } + bzero((void*)ls2, size); + return ls2; + } + if (sexp_unbox_integer(sexp_gc(ctx)) >= size) { + goto try_alloc; + } else { + fprintf(stderr, "chibi: out of memory trying to allocate %ld bytes, aborting\n", size); + exit(70); + } +} + +void sexp_gc_init () { + sexp next; + sexp_heap = malloc(SEXP_INITIAL_HEAP_SIZE); + sexp_heap_end = sexp_heap + SEXP_INITIAL_HEAP_SIZE; + sexp_free_list = (sexp)sexp_heap; + next = (sexp) (sexp_heap + sexp_sizeof(pair)); + sexp_pointer_tag(sexp_free_list) = SEXP_PAIR; + sexp_car(sexp_free_list) = 0; /* actually sexp_sizeof(pair) */ + sexp_cdr(sexp_free_list) = next; + sexp_pointer_tag(next) = SEXP_PAIR; + sexp_car(next) = (sexp) (SEXP_INITIAL_HEAP_SIZE-sexp_sizeof(pair)); + sexp_cdr(next) = SEXP_NULL; } diff --git a/sexp.c b/sexp.c index ee113fda..13190cd6 100644 --- a/sexp.c +++ b/sexp.c @@ -63,6 +63,7 @@ sexp sexp_alloc_tagged(sexp ctx, size_t size, sexp_uint_t tag) { } #if ! USE_BOEHM +#if USE_MALLOC void sexp_deep_free (sexp ctx, sexp obj) { int len, i; sexp *elts; @@ -87,6 +88,9 @@ void sexp_deep_free (sexp ctx, sexp obj) { sexp_free(ctx, obj); } } +#else +#include "gc.c" +#endif #endif /***************************** exceptions *****************************/ @@ -788,7 +792,7 @@ char* sexp_read_string(sexp ctx, sexp in) { } } - buf[i] = '\0'; + buf[i++] = '\0'; res = sexp_alloc(ctx, i); memcpy(res, buf, i); sexp_free(ctx, buf); @@ -819,7 +823,7 @@ char* sexp_read_symbol(sexp ctx, sexp in, int init) { } } - buf[i] = '\0'; + buf[i++] = '\0'; res = sexp_alloc(ctx, i); memcpy(res, buf, i); sexp_free(ctx, buf); @@ -1130,6 +1134,8 @@ void sexp_init() { GC_init(); GC_add_roots((char*)&symbol_table, ((char*)&symbol_table)+sizeof(symbol_table)+1); +#elif ! USE_MALLOC + sexp_gc_init(); #endif for (i=0; i #include +#include #include #include #include @@ -110,6 +111,11 @@ struct sexp_struct { struct { sexp kind, message, irritants, procedure, file, line; } exception; + struct { + char sign; + sexp_uint_t length; + sexp_uint_t *data; + } bignum; /* runtime types */ struct { char flags; @@ -168,6 +174,29 @@ struct sexp_struct { } value; }; +#if USE_BOEHM +#include "gc/include/gc.h" +#define sexp_alloc(ctx, size) GC_malloc(size) +#define sexp_alloc_atomic(ctx, size) GC_malloc_atomic(size) +#define sexp_realloc(ctx, x, size) GC_realloc(x, size) +#define sexp_free(ctx, x) +#define sexp_deep_free(ctx, x) +#elif USE_MALLOC +#define sexp_alloc(ctx, size) malloc(size) +#define sexp_alloc_atomic(ctx, size) malloc(size) +#define sexp_realloc(ctx, x, size) realloc(x, size) +#define sexp_free(ctx, x) free(x) +void sexp_deep_free(sexp ctx, sexp obj); +#else /* native gc */ +void *sexp_alloc(sexp ctx, size_t size); +#define sexp_alloc_atomic sexp_alloc +void *sexp_realloc(sexp ctx, sexp x, size_t size); +#define sexp_free(ctx, x) +#define sexp_deep_free(ctx, x) +#endif + +#define sexp_align(n, bits) (((n)+(1<<(bits))-1)&(((sexp_uint_t)-1)-((1<<(bits))-1))) + #define sexp_sizeof(x) (offsetof(struct sexp_struct, value) \ + sizeof(((sexp)0)->value.x)) @@ -196,6 +225,7 @@ struct sexp_struct { #define sexp_booleanp(x) (((x) == SEXP_TRUE) || ((x) == SEXP_FALSE)) #define sexp_pointer_tag(x) ((x)->tag) +#define sexp_gc_mark(x) ((x)->gc_mark) #define sexp_check_tag(x,t) (sexp_pointerp(x) && (sexp_pointer_tag(x) == (t))) From 28d5775bbe5090705c71b1872b7e08ad95625b07 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Wed, 6 May 2009 22:43:24 +0900 Subject: [PATCH 108/154] string and vector data is now packed, no longer allocing arbitrary blocks of untagged data, string and vector reads use an initial buffer to reduce allocations --- eval.c | 9 ++- gc.c | 85 +++++++++++++++++++--- main.c | 10 +-- sexp.c | 221 ++++++++++++++++++++++++++------------------------------- sexp.h | 52 ++++++++++---- 5 files changed, 229 insertions(+), 148 deletions(-) diff --git a/eval.c b/eval.c index bc384d9b..d0cfbd4e 100644 --- a/eval.c +++ b/eval.c @@ -240,10 +240,13 @@ static sexp sexp_make_context(sexp ctx, sexp *stack, sexp env) { sexp_bytecode_name(sexp_context_bc(res)) = SEXP_FALSE; sexp_bytecode_length(sexp_context_bc(res)) = INIT_BCODE_SIZE; sexp_bytecode_literals(sexp_context_bc(res)) = SEXP_NULL; + sexp_context_parent(res) = SEXP_FALSE; sexp_context_lambda(res) = SEXP_FALSE; sexp_context_stack(res) = stack; sexp_context_env(res) = env; sexp_context_fv(res) = SEXP_NULL; + sexp_context_saves(res).var = 0; + sexp_context_saves(res).next = 0; sexp_context_depth(res) = 0; sexp_context_pos(res) = 0; sexp_context_top(res) = 0; @@ -256,6 +259,7 @@ static sexp sexp_child_context(sexp context, sexp lambda) { sexp ctx = sexp_make_context(context, sexp_context_stack(context), sexp_context_env(context)); + sexp_context_parent(ctx) = context; sexp_context_lambda(ctx) = lambda; sexp_context_env(ctx) = sexp_context_env(context); sexp_context_top(ctx) = sexp_context_top(context); @@ -311,7 +315,8 @@ static sexp sexp_identifier_eq(sexp ctx, sexp e1, sexp id1, sexp e2, sexp id2) { static sexp sexp_compile_error(sexp ctx, char *message, sexp obj) { return sexp_make_exception(ctx, the_compile_error_symbol, - sexp_c_string(ctx, message), sexp_list1(ctx, obj), + sexp_c_string(ctx, message, -1), + sexp_list1(ctx, obj), SEXP_FALSE, SEXP_FALSE, SEXP_FALSE); } @@ -985,7 +990,7 @@ static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i, sexp env, sexp_push(context, refs, sexp_make_ref(context, sexp_car(ls), env_cell(env, sexp_car(ls)))); generate_opcode_app(sexp_cons(context, op, sexp_reverse(context, refs)), context); bc = finalize_bytecode(context); - sexp_bytecode_name(bc) = sexp_c_string(ctx, sexp_opcode_name(op)); + sexp_bytecode_name(bc) = sexp_c_string(ctx, sexp_opcode_name(op), -1); res = sexp_make_procedure(ctx, sexp_make_integer(0), sexp_make_integer(i), bc, SEXP_VOID); if (i == sexp_opcode_num_args(op)) diff --git a/gc.c b/gc.c index 8e9856b1..139fd7eb 100644 --- a/gc.c +++ b/gc.c @@ -55,12 +55,74 @@ void sexp_mark (sexp x) { goto loop; case SEXP_VECTOR: data = sexp_vector_data(x); - for (i=sexp_vector_length(x)-1; i>=0; i--) + for (i=sexp_vector_length(x)-1; i>0; i--) sexp_mark(data[i]); + x = data[i]; + goto loop; + case SEXP_BYTECODE: + x = sexp_bytecode_literals(x); + goto loop; + case SEXP_ENV: + sexp_mark(sexp_env_lambda(x)); + sexp_mark(sexp_env_bindings(x)); + x = sexp_env_parent(x); + if (x) goto loop; else break; + case SEXP_PROCEDURE: + sexp_mark(sexp_procedure_code(x)); + x = sexp_procedure_vars(x); + goto loop; + case SEXP_MACRO: + sexp_mark(sexp_macro_proc(x)); + x = sexp_macro_env(x); + goto loop; + case SEXP_SYNCLO: + sexp_mark(sexp_synclo_free_vars(x)); + sexp_mark(sexp_synclo_expr(x)); + x = sexp_synclo_env(x); + goto loop; + case SEXP_OPCODE: + if (sexp_opcode_proc(x)) sexp_mark(sexp_opcode_proc(x)); + if (sexp_opcode_default(x)) sexp_mark(sexp_opcode_default(x)); + if (sexp_opcode_data(x)) sexp_mark(sexp_opcode_data(x)); + break; + case SEXP_IPORT: + case SEXP_OPORT: + x = sexp_port_cookie(x); + if (x) goto loop; else break; + case SEXP_LAMBDA: + sexp_mark(sexp_lambda_name(x)); + sexp_mark(sexp_lambda_params(x)); + sexp_mark(sexp_lambda_locals(x)); + sexp_mark(sexp_lambda_defs(x)); + sexp_mark(sexp_lambda_flags(x)); + sexp_mark(sexp_lambda_body(x)); + sexp_mark(sexp_lambda_fv(x)); + sexp_mark(sexp_lambda_sv(x)); + x = sexp_lambda_body(x); + goto loop; + case SEXP_CND: + sexp_mark(sexp_cnd_test(x)); + sexp_mark(sexp_cnd_fail(x)); + x = sexp_cnd_pass(x); + goto loop; + case SEXP_SET: + sexp_mark(sexp_set_var(x)); + x = sexp_set_value(x); + goto loop; + case SEXP_REF: + sexp_mark(sexp_ref_name(x)); + x = sexp_ref_cell(x); + goto loop; + case SEXP_SEQ: + x = sexp_seq_ls(x); + goto loop; + case SEXP_LIT: + x = sexp_lit_value(x); + goto loop; } } -sexp sexp_sweep () { +sexp sexp_sweep (sexp ctx) { sexp_uint_t freed=0, size; sexp p=(sexp)sexp_heap, f1=sexp_free_list, f2; while ((char*)pnext) + if (saves->var) sexp_mark(*(saves->var)); + } + return sexp_sweep(ctx); } void *sexp_alloc (sexp ctx, size_t size) { diff --git a/main.c b/main.c index fd90e900..4a36ef40 100644 --- a/main.c +++ b/main.c @@ -66,7 +66,7 @@ void run_main (int argc, char **argv) { case 'e': case 'p': if (! init_loaded++) - sexp_load(context, sexp_c_string(context, sexp_init_file), env); + sexp_load(context, sexp_c_string(context, sexp_init_file, -1), env); res = sexp_read_from_string(context, argv[i+1]); if (! sexp_exceptionp(res)) res = eval_in_context(res, context); @@ -82,8 +82,8 @@ void run_main (int argc, char **argv) { #endif case 'l': if (! init_loaded++) - sexp_load(context, sexp_c_string(context, sexp_init_file), env); - sexp_load(context, sexp_c_string(context, argv[++i]), env); + sexp_load(context, sexp_c_string(context, sexp_init_file, -1), env); + sexp_load(context, sexp_c_string(context, argv[++i], -1), env); break; case 'q': init_loaded = 1; @@ -95,10 +95,10 @@ void run_main (int argc, char **argv) { if (! quit) { if (! init_loaded) - sexp_load(context, sexp_c_string(context, sexp_init_file), env); + sexp_load(context, sexp_c_string(context, sexp_init_file, -1), env); if (i < argc) for ( ; i < argc; i++) - sexp_load(context, sexp_c_string(context, argv[i]), env); + sexp_load(context, sexp_c_string(context, argv[i], -1), env); else repl(context); } diff --git a/sexp.c b/sexp.c index 13190cd6..78532be1 100644 --- a/sexp.c +++ b/sexp.c @@ -45,13 +45,7 @@ static int is_separator(int c) { return 0= 0) ? slen : strlen(str)); sexp s = sexp_make_string(ctx, sexp_make_integer(len), SEXP_VOID); - memcpy(sexp_string_data(s), str, len); + memcpy(sexp_string_data(s), str, len+1); return s; } @@ -361,22 +354,26 @@ sexp sexp_substring (sexp ctx, sexp str, sexp start, sexp end) { res = sexp_make_string(ctx, sexp_fx_sub(end, start), SEXP_VOID); memcpy(sexp_string_data(res), sexp_string_data(str)+sexp_unbox_integer(start), - sexp_string_length(res)); + sexp_string_length(res)+1); return res; } +#if USE_HASH_SYMS + #define FNV_PRIME 16777619 #define FNV_OFFSET_BASIS 2166136261uL -sexp_uint_t sexp_string_hash(char *str, sexp_uint_t acc) { +static sexp_uint_t sexp_string_hash(char *str, sexp_uint_t acc) { while (*str) {acc *= FNV_PRIME; acc ^= *str++;} return acc; } +#endif + sexp sexp_intern(sexp ctx, char *str) { struct huff_entry he; sexp_uint_t len, res=FNV_OFFSET_BASIS, space=3, newbits, bucket; - char c, *mystr, *p=str; + char c, *p=str; sexp sym, ls; #if USE_HUFF_SYMS @@ -400,18 +397,14 @@ sexp sexp_intern(sexp ctx, char *str) { bucket = 0; #endif len = strlen(str); - for (ls=symbol_table[bucket]; sexp_pairp(ls); ls=sexp_cdr(ls)) - if (strncmp(str, sexp_symbol_data(sexp_car(ls)), len) == 0) + for (ls=sexp_symbol_table[bucket]; sexp_pairp(ls); ls=sexp_cdr(ls)) + if (! strncmp(str, sexp_string_data(sexp_symbol_string(sexp_car(ls))), len)) return sexp_car(ls); /* not found, make a new symbol */ sym = sexp_alloc_type(ctx, symbol, SEXP_SYMBOL); - mystr = sexp_alloc(ctx, len+1); - memcpy(mystr, str, len+1); - mystr[len]=0; - sexp_symbol_length(sym) = len; - sexp_symbol_data(sym) = mystr; - sexp_push(ctx, symbol_table[bucket], sym); + sexp_symbol_string(sym) = sexp_c_string(ctx, str, len); + sexp_push(ctx, sexp_symbol_table[bucket], sym); return sym; } @@ -423,12 +416,12 @@ sexp sexp_make_vector(sexp ctx, sexp len, sexp dflt) { sexp v, *x; int i, clen = sexp_unbox_integer(len); if (! clen) return the_empty_vector; - v = sexp_alloc_type(ctx, vector, SEXP_VECTOR); - x = (sexp*) sexp_alloc(ctx, clen*sizeof(sexp)); + v = sexp_alloc(ctx, sexp_sizeof(vector) + clen*sizeof(sexp)); + sexp_pointer_tag(v) = SEXP_VECTOR; + x = sexp_vector_data(v); for (i=0; i0; str++, i--) { if ((str[0] == '\\') || is_separator(str[0])) sexp_write_char('\\', out); @@ -763,70 +756,67 @@ void sexp_write (sexp obj, sexp out) { } } -char* sexp_read_string(sexp ctx, sexp in) { - char *buf, *tmp, *res; - int c, i=0, size=128; +#define INIT_STRING_BUFFER_SIZE 128 - buf = sexp_alloc(ctx, size); +sexp sexp_read_string(sexp ctx, sexp in) { + int c, i=0, size=INIT_STRING_BUFFER_SIZE; + char initbuf[INIT_STRING_BUFFER_SIZE]; + char *buf=initbuf, *tmp; + sexp res; - for (c=sexp_read_char(in); c != '"'; c=sexp_read_char(in)) { - if (c == EOF) { - sexp_free(ctx, buf); - return NULL; - } + for (c = sexp_read_char(in); c != '"'; c = sexp_read_char(in)) { if (c == '\\') { - c=sexp_read_char(in); - switch (c) { - case 'n': c = '\n'; break; - case 't': c = '\t'; break; - } - buf[i++] = c; - } else { - buf[i++] = c; + c = sexp_read_char(in); + switch (c) {case 'n': c = '\n'; break; case 't': c = '\t'; break;} } - if (i >= size) { - tmp = sexp_alloc(ctx, 2*size); + if (c == EOF) { + res = sexp_read_error(ctx, "premature end of string", SEXP_NULL, in); + break; + } + buf[i++] = c; + if (i >= size) { /* expand buffer w/ malloc(), later free() it */ + tmp = malloc(size*2); memcpy(tmp, buf, i); - sexp_free(ctx, buf); + if (size != INIT_STRING_BUFFER_SIZE) free(buf); buf = tmp; + size *= 2; } } - buf[i++] = '\0'; - res = sexp_alloc(ctx, i); - memcpy(res, buf, i); - sexp_free(ctx, buf); + buf[i] = '\0'; + res = sexp_c_string(ctx, buf, i); + if (size != INIT_STRING_BUFFER_SIZE) free(buf); return res; } -char* sexp_read_symbol(sexp ctx, sexp in, int init) { - char *buf, *tmp, *res; - int c, i=0, size=128; - - buf = sexp_alloc(ctx, size); +sexp sexp_read_symbol(sexp ctx, sexp in, int init, int internp) { + int c, i=0, size=INIT_STRING_BUFFER_SIZE; + char initbuf[INIT_STRING_BUFFER_SIZE]; + char *buf=initbuf, *tmp; + sexp res; if (init != EOF) buf[i++] = init; - while (1) { - c=sexp_read_char(in); + for (c = sexp_read_char(in); c != '"'; c = sexp_read_char(in)) { + if (c == '\\') c = sexp_read_char(in); if (c == EOF || is_separator(c)) { sexp_push_char(c, in); break; } buf[i++] = c; - if (i >= size) { - tmp = sexp_alloc(ctx, 2*size); + if (i >= size) { /* expand buffer w/ malloc(), later free() it */ + tmp = malloc(size*2); memcpy(tmp, buf, i); - sexp_free(ctx, buf); + if (size != INIT_STRING_BUFFER_SIZE) free(buf); buf = tmp; + size *= 2; } } - buf[i++] = '\0'; - res = sexp_alloc(ctx, i); - memcpy(res, buf, i); - sexp_free(ctx, buf); + buf[i] = '\0'; + res = (internp ? sexp_intern(ctx, buf) : sexp_c_string(ctx, buf, i)); + if (size != INIT_STRING_BUFFER_SIZE) free(buf); return res; } @@ -929,12 +919,7 @@ sexp sexp_read_raw (sexp ctx, sexp in) { } break; case '"': - str = sexp_read_string(ctx, in); - if (! str) - res = sexp_read_error(ctx, "premature end of string", SEXP_NULL, in); - else - res = sexp_c_string(ctx, str); - sexp_free(ctx, str); + res = sexp_read_string(ctx, in); break; case '(': res = SEXP_NULL; @@ -1007,31 +992,34 @@ sexp sexp_read_raw (sexp ctx, sexp in) { goto scan_loop; case '\\': c1 = sexp_read_char(in); - str = sexp_read_symbol(ctx, in, c1); - if (str[0] == '\0') - res = - sexp_read_error(ctx, "unexpected end of character literal", SEXP_NULL, in); - if (str[1] == '\0') { - res = sexp_make_character(c1); - } else if ((c1 == 'x' || c1 == 'X') && - isxdigit(str[0]) && isxdigit(str[1]) && str[2] == '\0') { - res = sexp_make_character(16 * digit_value(c1) + digit_value(str[1])); - } else { - if (strcasecmp(str, "space") == 0) - res = sexp_make_character(' '); - else if (strcasecmp(str, "newline") == 0) - res = sexp_make_character('\n'); - else if (strcasecmp(str, "return") == 0) - res = sexp_make_character('\r'); - else if (strcasecmp(str, "tab") == 0) - res = sexp_make_character('\t'); - else { - res = sexp_read_error(ctx, "unknown character name", - sexp_list1(ctx, sexp_c_string(ctx, str)), - in); + res = sexp_read_symbol(ctx, in, c1, 0); + if (sexp_stringp(res)) { + str = sexp_string_data(res); + if (sexp_string_length(res) == 0) + res = + sexp_read_error(ctx, "unexpected end of character literal", + SEXP_NULL, in); + if (sexp_string_length(res) == 1) { + res = sexp_make_character(c1); + } else if ((c1 == 'x' || c1 == 'X') && + isxdigit(str[0]) && isxdigit(str[1]) && str[2] == '\0') { + res = sexp_make_character(16 * digit_value(c1) + digit_value(str[1])); + } else { + if (strcasecmp(str, "space") == 0) + res = sexp_make_character(' '); + else if (strcasecmp(str, "newline") == 0) + res = sexp_make_character('\n'); + else if (strcasecmp(str, "return") == 0) + res = sexp_make_character('\r'); + else if (strcasecmp(str, "tab") == 0) + res = sexp_make_character('\t'); + else { + res = sexp_read_error(ctx, "unknown character name", + sexp_list1(ctx, sexp_c_string(ctx, str, -1)), + in); + } } } - sexp_free(ctx, str); break; case '(': sexp_push_char(c1, in); @@ -1061,9 +1049,7 @@ sexp sexp_read_raw (sexp ctx, sexp in) { res = sexp_read_float_tail(ctx, in, 0); } else { sexp_push_char(c1, in); - str = sexp_read_symbol(ctx, in, '.'); - res = sexp_intern(ctx, str); - sexp_free(ctx, str); + res = sexp_read_symbol(ctx, in, '.', 1); } break; case ')': @@ -1086,9 +1072,7 @@ sexp sexp_read_raw (sexp ctx, sexp in) { } } else { sexp_push_char(c2, in); - str = sexp_read_symbol(ctx, in, c1); - res = sexp_intern(ctx, str); - sexp_free(ctx, str); + res = sexp_read_symbol(ctx, in, c1, 1); } break; case '0': case '1': case '2': case '3': case '4': @@ -1097,9 +1081,7 @@ sexp sexp_read_raw (sexp ctx, sexp in) { res = sexp_read_number(ctx, in, 10); break; default: - str = sexp_read_symbol(ctx, in, c1); - res = sexp_intern(ctx, str); - sexp_free(ctx, str); + res = sexp_read_symbol(ctx, in, c1, 1); break; } return res; @@ -1116,7 +1098,7 @@ sexp sexp_read (sexp ctx, sexp in) { #if USE_STRING_STREAMS sexp sexp_read_from_string(sexp ctx, char *str) { - sexp s = sexp_c_string(ctx, str); + sexp s = sexp_c_string(ctx, str, -1); sexp in = sexp_make_input_string_port(ctx, s); sexp res = sexp_read(ctx, in); sexp_free(ctx, s); @@ -1132,13 +1114,13 @@ void sexp_init() { sexp_initialized_p = 1; #if USE_BOEHM GC_init(); - GC_add_roots((char*)&symbol_table, - ((char*)&symbol_table)+sizeof(symbol_table)+1); + GC_add_roots((char*)&sexp_symbol_table, + ((char*)&sexp_symbol_table)+sizeof(sexp_symbol_table)+1); #elif ! USE_MALLOC sexp_gc_init(); #endif for (i=0; ivalue.symbol.length) -#define sexp_symbol_data(x) ((x)->value.symbol.data) +#define sexp_symbol_string(x) ((x)->value.symbol.string) #define sexp_port_stream(p) ((p)->value.port.stream) #define sexp_port_name(p) ((p)->value.port.name) @@ -375,6 +402,8 @@ void *sexp_realloc(sexp ctx, sexp x, size_t size); #define sexp_context_pos(x) ((x)->value.context.pos) #define sexp_context_top(x) ((x)->value.context.top) #define sexp_context_lambda(x) ((x)->value.context.lambda) +#define sexp_context_parent(x) ((x)->value.context.parent) +#define sexp_context_saves(x) ((x)->value.context.saves) #define sexp_context_tailp(x) ((x)->value.context.tailp) #define sexp_context_tracep(x) ((x)->value.context.tailp) @@ -440,19 +469,18 @@ sexp sexp_append2(sexp ctx, sexp a, sexp b); sexp sexp_memq(sexp ctx, sexp x, sexp ls); sexp sexp_assq(sexp ctx, sexp x, sexp ls); sexp sexp_length(sexp ctx, sexp ls); -sexp sexp_c_string(sexp ctx, char *str); +sexp sexp_c_string(sexp ctx, char *str, sexp_sint_t slen); sexp sexp_make_string(sexp ctx, sexp len, sexp ch); sexp sexp_substring (sexp ctx, sexp str, sexp start, sexp end); sexp sexp_make_flonum(sexp ctx, double f); -sexp_uint_t sexp_string_hash(char *str, sexp_uint_t acc); sexp sexp_intern(sexp ctx, char *str); sexp sexp_string_to_symbol(sexp ctx, sexp str); sexp sexp_make_vector(sexp ctx, sexp len, sexp dflt); sexp sexp_list_to_vector(sexp ctx, sexp ls); sexp sexp_vector(sexp ctx, int count, ...); void sexp_write(sexp obj, sexp out); -char* sexp_read_string(sexp ctx, sexp in); -char* sexp_read_symbol(sexp ctx, sexp in, int init); +sexp sexp_read_string(sexp ctx, sexp in); +sexp sexp_read_symbol(sexp ctx, sexp in, int init, int internp); sexp sexp_read_number(sexp ctx, sexp in, int base); sexp sexp_read_raw(sexp ctx, sexp in); sexp sexp_read(sexp ctx, sexp in); From a85d80038cd9b192a41c9be1f4d6390787fd0019 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Fri, 8 May 2009 23:27:04 +0900 Subject: [PATCH 109/154] while still working towards the precise gc, reordering the context argument to all functions --- eval.c | 812 ++++++++++++++++++++++++++++++--------------------------- gc.c | 2 +- main.c | 68 ++--- sexp.c | 60 +++-- sexp.h | 42 ++- 5 files changed, 533 insertions(+), 451 deletions(-) diff --git a/eval.c b/eval.c index d0cfbd4e..5e0d5d9e 100644 --- a/eval.c +++ b/eval.c @@ -21,8 +21,8 @@ static sexp the_cur_in_symbol, the_cur_out_symbol, the_cur_err_symbol; #define sexp_disasm(...) #endif -static sexp analyze (sexp x, sexp context); -static void generate (sexp x, sexp context); +static sexp analyze (sexp ctx, sexp x); +static void generate (sexp ctx, sexp x); static sexp sexp_make_null_env (sexp ctx, sexp version); static sexp sexp_make_standard_env (sexp ctx, sexp version); @@ -42,12 +42,15 @@ static sexp env_cell(sexp e, sexp key) { } static sexp env_cell_create(sexp ctx, sexp e, sexp key, sexp value) { - sexp cell = env_cell(e, key); + sexp_gc_var(ctx, cell, s_cell); + cell = env_cell(e, key); if (! cell) { + sexp_gc_preserve(ctx, cell, s_cell); cell = sexp_cons(ctx, key, value); while (sexp_env_parent(e)) e = sexp_env_parent(e); sexp_env_bindings(e) = sexp_cons(ctx, cell, sexp_env_bindings(e)); + sexp_gc_release(ctx, cell, s_cell); } return cell; } @@ -69,18 +72,28 @@ static void env_define(sexp ctx, sexp e, sexp key, sexp value) { } static sexp extend_env (sexp ctx, sexp env, sexp vars, sexp value) { - sexp e = sexp_alloc_type(ctx, env, SEXP_ENV); + sexp_gc_var(ctx, e, s_e); + sexp_gc_var(ctx, tmp, s_tmp); + sexp_gc_preserve(ctx, e, s_e); + sexp_gc_preserve(ctx, tmp, s_tmp); + e = sexp_alloc_type(ctx, env, SEXP_ENV); sexp_env_parent(e) = env; sexp_env_bindings(e) = SEXP_NULL; - for ( ; sexp_pairp(vars); vars = sexp_cdr(vars)) - sexp_push(ctx, sexp_env_bindings(e), sexp_cons(ctx, sexp_car(vars), value)); + for ( ; sexp_pairp(vars); vars = sexp_cdr(vars)) { + tmp = sexp_cons(ctx, sexp_car(vars), value); + sexp_push(ctx, sexp_env_bindings(e), tmp); + } + sexp_gc_release(ctx, e, s_e); + sexp_gc_release(ctx, tmp, s_tmp); return e; } static sexp sexp_reverse_flatten_dot (sexp ctx, sexp ls) { - sexp res; + sexp_gc_var(ctx, res, s_res); + sexp_gc_preserve(ctx, res, s_res); for (res=SEXP_NULL; sexp_pairp(ls); ls=sexp_cdr(ls)) sexp_push(ctx, res, sexp_car(ls)); + sexp_gc_release(ctx, res, s_res); return (sexp_nullp(ls) ? res : sexp_cons(ctx, ls, res)); } @@ -105,59 +118,59 @@ static int sexp_param_index (sexp lambda, sexp name) { /************************* bytecode utilities ***************************/ -static void shrink_bcode(sexp context, sexp_uint_t i) { +static void shrink_bcode(sexp ctx, sexp_uint_t i) { sexp tmp; - if (sexp_bytecode_length(sexp_context_bc(context)) != i) { - tmp = sexp_alloc_tagged(context, sexp_sizeof(bytecode) + i, SEXP_BYTECODE); + if (sexp_bytecode_length(sexp_context_bc(ctx)) != i) { + tmp = sexp_alloc_tagged(ctx, sexp_sizeof(bytecode) + i, SEXP_BYTECODE); sexp_bytecode_name(tmp) = SEXP_FALSE; sexp_bytecode_length(tmp) = i; sexp_bytecode_literals(tmp) - = sexp_bytecode_literals(sexp_context_bc(context)); + = sexp_bytecode_literals(sexp_context_bc(ctx)); memcpy(sexp_bytecode_data(tmp), - sexp_bytecode_data(sexp_context_bc(context)), + sexp_bytecode_data(sexp_context_bc(ctx)), i); - sexp_context_bc(context) = tmp; + sexp_context_bc(ctx) = tmp; } } -static void expand_bcode(sexp context, sexp_uint_t size) { +static void expand_bcode(sexp ctx, sexp_uint_t size) { sexp tmp; - if (sexp_bytecode_length(sexp_context_bc(context)) - < (sexp_context_pos(context))+size) { - tmp = sexp_alloc_tagged(context, + if (sexp_bytecode_length(sexp_context_bc(ctx)) + < (sexp_context_pos(ctx))+size) { + tmp = sexp_alloc_tagged(ctx, sexp_sizeof(bytecode) - + sexp_bytecode_length(sexp_context_bc(context))*2, + + sexp_bytecode_length(sexp_context_bc(ctx))*2, SEXP_BYTECODE); sexp_bytecode_name(tmp) = SEXP_FALSE; sexp_bytecode_length(tmp) - = sexp_bytecode_length(sexp_context_bc(context))*2; + = sexp_bytecode_length(sexp_context_bc(ctx))*2; sexp_bytecode_literals(tmp) - = sexp_bytecode_literals(sexp_context_bc(context)); + = sexp_bytecode_literals(sexp_context_bc(ctx)); memcpy(sexp_bytecode_data(tmp), - sexp_bytecode_data(sexp_context_bc(context)), - sexp_bytecode_length(sexp_context_bc(context))); - sexp_context_bc(context) = tmp; + sexp_bytecode_data(sexp_context_bc(ctx)), + sexp_bytecode_length(sexp_context_bc(ctx))); + sexp_context_bc(ctx) = tmp; } } -static void emit(char c, sexp context) { - expand_bcode(context, 1); - sexp_bytecode_data(sexp_context_bc(context))[sexp_context_pos(context)++] = c; +static void emit(sexp ctx, char c) { + expand_bcode(ctx, 1); + sexp_bytecode_data(sexp_context_bc(ctx))[sexp_context_pos(ctx)++] = c; } -static void emit_word(sexp_uint_t val, sexp context) { +static void emit_word(sexp ctx, sexp_uint_t val) { unsigned char *data; - expand_bcode(context, sizeof(sexp)); - data = sexp_bytecode_data(sexp_context_bc(context)); - *((sexp_uint_t*)(&(data[sexp_context_pos(context)]))) = val; - sexp_context_pos(context) += sizeof(sexp); + expand_bcode(ctx, sizeof(sexp)); + data = sexp_bytecode_data(sexp_context_bc(ctx)); + *((sexp_uint_t*)(&(data[sexp_context_pos(ctx)]))) = val; + sexp_context_pos(ctx) += sizeof(sexp); } -static void emit_push(sexp obj, sexp context) { - emit(OP_PUSH, context); - emit_word((sexp_uint_t)obj, context); +static void emit_push(sexp ctx, sexp obj) { + emit(ctx, OP_PUSH); + emit_word(ctx, (sexp_uint_t)obj); if (sexp_pointerp(obj)) - sexp_push(context, sexp_bytecode_literals(sexp_context_bc(context)), obj); + sexp_push(ctx, sexp_bytecode_literals(sexp_context_bc(ctx)), obj); } static sexp sexp_make_procedure(sexp ctx, sexp flags, sexp num_args, @@ -230,32 +243,33 @@ static sexp sexp_make_lit(sexp ctx, sexp value) { } static sexp sexp_make_context(sexp ctx, sexp *stack, sexp env) { - sexp res = sexp_alloc_type(ctx, context, SEXP_CONTEXT); - if (! stack) - stack = (sexp*) sexp_alloc(ctx, sizeof(sexp)*INIT_STACK_SIZE); - if (! env) - env = sexp_make_standard_env(ctx, sexp_make_integer(5)); + sexp_gc_var(ctx, res, save_res); + if (ctx) sexp_gc_preserve(ctx, res, save_res); + res = sexp_alloc_type(ctx, context, SEXP_CONTEXT); + sexp_context_stack(res) + = (stack ? stack : (sexp*) sexp_alloc(res, sizeof(sexp)*INIT_STACK_SIZE)); + sexp_context_env(res) + = (env ? env : sexp_make_standard_env(res, sexp_make_integer(5))); sexp_context_bc(res) - = sexp_alloc_tagged(ctx, sexp_sizeof(bytecode)+INIT_BCODE_SIZE, SEXP_BYTECODE); + = sexp_alloc_tagged(ctx, sexp_sizeof(bytecode)+INIT_BCODE_SIZE, + SEXP_BYTECODE); sexp_bytecode_name(sexp_context_bc(res)) = SEXP_FALSE; sexp_bytecode_length(sexp_context_bc(res)) = INIT_BCODE_SIZE; sexp_bytecode_literals(sexp_context_bc(res)) = SEXP_NULL; sexp_context_parent(res) = SEXP_FALSE; sexp_context_lambda(res) = SEXP_FALSE; - sexp_context_stack(res) = stack; - sexp_context_env(res) = env; sexp_context_fv(res) = SEXP_NULL; - sexp_context_saves(res).var = 0; - sexp_context_saves(res).next = 0; + sexp_context_saves(res) = 0; sexp_context_depth(res) = 0; sexp_context_pos(res) = 0; sexp_context_top(res) = 0; sexp_context_tailp(res) = 0; sexp_context_tracep(res) = 0; + if (ctx) sexp_gc_release(ctx, res, save_res); return res; } -static sexp sexp_child_context(sexp context, sexp lambda) { +static sexp sexp_make_child_context(sexp context, sexp lambda) { sexp ctx = sexp_make_context(context, sexp_context_stack(context), sexp_context_env(context)); @@ -268,8 +282,6 @@ static sexp sexp_child_context(sexp context, sexp lambda) { return ctx; } -#define sexp_idp(x) (sexp_symbolp(x) || (sexp_synclop(x) && sexp_symbolp(sexp_synclo_expr(x)))) - static sexp sexp_identifierp (sexp ctx, sexp x) { return sexp_make_boolean(sexp_idp(x)); } @@ -279,17 +291,25 @@ static sexp sexp_syntactic_closure_expr (sexp ctx, sexp x) { } static sexp sexp_strip_synclos (sexp ctx, sexp x) { + sexp res; + sexp_gc_var(ctx, kar, s_kar); + sexp_gc_var(ctx, kdr, s_kdr); + sexp_gc_preserve(ctx, kar, s_kar); + sexp_gc_preserve(ctx, kdr, s_kdr); loop: if (sexp_synclop(x)) { x = sexp_synclo_expr(x); goto loop; } else if (sexp_pairp(x)) { - return sexp_cons(ctx, - sexp_strip_synclos(ctx, sexp_car(x)), - sexp_strip_synclos(ctx, sexp_cdr(x))); + kar = sexp_strip_synclos(ctx, sexp_car(x)); + kdr = sexp_strip_synclos(ctx, sexp_cdr(x)); + res = sexp_cons(ctx, kar, kdr); } else { - return x; + res = x; } + sexp_gc_release(ctx, kar, s_kar); + sexp_gc_release(ctx, kdr, s_kdr); + return res; } static sexp sexp_identifier_eq(sexp ctx, sexp e1, sexp id1, sexp e2, sexp id2) { @@ -324,153 +344,181 @@ static sexp sexp_compile_error(sexp ctx, char *message, sexp obj) { return (x); \ } while (0) -#define analyze_bind(var, x, context) do {(var) = analyze(x,context); \ - analyze_check_exception(var); \ +#define analyze_bind(var, x, ctx) do {(var) = analyze(ctx, x); \ + analyze_check_exception(var); \ } while (0) -static sexp analyze_app (sexp x, sexp context) { - sexp res=SEXP_NULL, tmp; - for ( ; sexp_pairp(x); x=sexp_cdr(x)) { - analyze_bind(tmp, sexp_car(x), context); - sexp_push(context, res, tmp); +static sexp analyze_app (sexp ctx, sexp x) { + sexp tmp; + sexp_gc_var(ctx, res, s_res); + sexp_gc_preserve(ctx, res, s_res); + for (res=SEXP_NULL; sexp_pairp(x); x=sexp_cdr(x)) { + sexp_push(ctx, res, SEXP_FALSE); + tmp = analyze(ctx, sexp_car(x)); + if (sexp_exceptionp(tmp)) { + res = tmp; + break; + } else + sexp_car(res) = tmp; } - return sexp_nreverse(context, res); + sexp_gc_release(ctx, res, s_res); + return (sexp_pairp(res) ? sexp_nreverse(ctx, res) : res); } -static sexp analyze_seq (sexp ls, sexp context) { - sexp res, tmp; +static sexp analyze_seq (sexp ctx, sexp ls) { + sexp tmp; + sexp_gc_var(ctx, res, s_res); + sexp_gc_preserve(ctx, res, s_res); if (sexp_nullp(ls)) res = SEXP_VOID; else if (sexp_nullp(sexp_cdr(ls))) - res = analyze(sexp_car(ls), context); + res = analyze(ctx, sexp_car(ls)); else { - res = sexp_alloc_type(context, seq, SEXP_SEQ); - tmp = analyze_app(ls, context); - analyze_check_exception(tmp); - sexp_seq_ls(res) = tmp; + res = sexp_alloc_type(ctx, seq, SEXP_SEQ); + tmp = analyze_app(ctx, ls); + if (sexp_exceptionp(tmp)) + res = tmp; + else + sexp_seq_ls(res) = tmp; } + sexp_gc_release(ctx, res, s_res); return res; } -static sexp analyze_var_ref (sexp x, sexp context) { - sexp env = sexp_context_env(context), cell; +static sexp analyze_var_ref (sexp ctx, sexp x) { + sexp env = sexp_context_env(ctx), res; + sexp_gc_var(ctx, cell, s_cell); + sexp_gc_preserve(ctx, cell, s_cell); cell = env_cell(env, x); if (! cell) { if (sexp_synclop(x)) { - if (sexp_memq(context, x, sexp_context_fv(context)) != SEXP_FALSE) + if (sexp_memq(ctx, x, sexp_context_fv(ctx)) != SEXP_FALSE) env = sexp_synclo_env(x); x = sexp_synclo_expr(x); } - cell = env_cell_create(context, env, x, SEXP_UNDEF); + cell = env_cell_create(ctx, env, x, SEXP_UNDEF); } if (sexp_macrop(sexp_cdr(cell)) || sexp_corep(sexp_cdr(cell))) - return sexp_compile_error(context, "invalid use of syntax as value", x); - return sexp_make_ref(context, x, cell); + res = sexp_compile_error(ctx, "invalid use of syntax as value", x); + else + res = sexp_make_ref(ctx, x, cell); + sexp_gc_release(ctx, cell, s_cell); + return res; } -static sexp analyze_set (sexp x, sexp context) { - sexp ref, value; - ref = analyze_var_ref(sexp_cadr(x), context); +static sexp analyze_set (sexp ctx, sexp x) { + sexp res; + sexp_gc_var(ctx, ref, s_ref); + sexp_gc_var(ctx, value, s_value); + sexp_gc_preserve(ctx, ref, s_ref); + sexp_gc_preserve(ctx, value, s_value); + ref = analyze_var_ref(ctx, sexp_cadr(x)); if (sexp_lambdap(sexp_ref_loc(ref))) - sexp_insert(context, sexp_lambda_sv(sexp_ref_loc(ref)), sexp_ref_name(ref)); - analyze_check_exception(ref); - analyze_bind(value, sexp_caddr(x), context); - return sexp_make_set(context, ref, value); + sexp_insert(ctx, sexp_lambda_sv(sexp_ref_loc(ref)), sexp_ref_name(ref)); + value = analyze(ctx, sexp_caddr(x)); + if (sexp_exceptionp(ref)) + res = ref; + else if (sexp_exceptionp(value)) + res = value; + else + res = sexp_make_set(ctx, ref, value); + sexp_gc_release(ctx, ref, s_ref); + sexp_gc_release(ctx, value, s_value); + return res; } -static sexp analyze_lambda (sexp x, sexp context) { +static sexp analyze_lambda (sexp ctx, sexp x) { sexp res, body, ls, tmp, name, value, defs=SEXP_NULL; /* verify syntax */ if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) - return sexp_compile_error(context, "bad lambda syntax", x); + return sexp_compile_error(ctx, "bad lambda syntax", x); for (ls=sexp_cadr(x); sexp_pairp(ls); ls=sexp_cdr(ls)) if (! sexp_idp(sexp_car(ls))) - return sexp_compile_error(context, "non-symbol parameter", x); - else if (sexp_memq(context, sexp_car(ls), sexp_cdr(ls)) != SEXP_FALSE) - return sexp_compile_error(context, "duplicate parameter", x); + return sexp_compile_error(ctx, "non-symbol parameter", x); + else if (sexp_memq(ctx, sexp_car(ls), sexp_cdr(ls)) != SEXP_FALSE) + return sexp_compile_error(ctx, "duplicate parameter", x); /* build lambda and analyze body */ - res = sexp_make_lambda(context, sexp_cadr(x)); - context = sexp_child_context(context, res); - sexp_context_env(context) - = extend_env(context, - sexp_context_env(context), - sexp_flatten_dot(context, sexp_lambda_params(res)), + res = sexp_make_lambda(ctx, sexp_cadr(x)); + ctx = sexp_make_child_context(ctx, res); + sexp_context_env(ctx) + = extend_env(ctx, + sexp_context_env(ctx), + sexp_flatten_dot(ctx, sexp_lambda_params(res)), res); - sexp_env_lambda(sexp_context_env(context)) = res; - body = analyze_seq(sexp_cddr(x), context); + sexp_env_lambda(sexp_context_env(ctx)) = res; + body = analyze_seq(ctx, sexp_cddr(x)); analyze_check_exception(body); /* delayed analyze internal defines */ for (ls=sexp_lambda_defs(res); sexp_pairp(ls); ls=sexp_cdr(ls)) { tmp = sexp_car(ls); if (sexp_pairp(sexp_cadr(tmp))) { name = sexp_caadr(tmp); - value = analyze_lambda(sexp_cons(context, + value = analyze_lambda(ctx, + sexp_cons(ctx, SEXP_VOID, - sexp_cons(context, + sexp_cons(ctx, sexp_cdadr(tmp), - sexp_cddr(tmp))), - context); + sexp_cddr(tmp)))); } else { name = sexp_cadr(tmp); - value = analyze(sexp_caddr(tmp), context); + value = analyze(ctx, sexp_caddr(tmp)); } analyze_check_exception(value); - sexp_push(context, defs, - sexp_make_set(context, analyze_var_ref(name, context), value)); + sexp_push(ctx, defs, sexp_make_set(ctx, analyze_var_ref(ctx, name), value)); } if (sexp_pairp(defs)) { if (! sexp_seqp(body)) { - tmp = sexp_alloc_type(context, seq, SEXP_SEQ); - sexp_seq_ls(tmp) = sexp_list1(context, body); + tmp = sexp_alloc_type(ctx, seq, SEXP_SEQ); + sexp_seq_ls(tmp) = sexp_list1(ctx, body); body = tmp; } - sexp_seq_ls(body) = sexp_append2(context, defs, sexp_seq_ls(body)); + sexp_seq_ls(body) = sexp_append2(ctx, defs, sexp_seq_ls(body)); } sexp_lambda_body(res) = body; return res; } -static sexp analyze_if (sexp x, sexp context) { +static sexp analyze_if (sexp ctx, sexp x) { sexp test, pass, fail, fail_expr; - analyze_bind(test, sexp_cadr(x), context); - analyze_bind(pass, sexp_caddr(x), context); + analyze_bind(test, sexp_cadr(x), ctx); + analyze_bind(pass, sexp_caddr(x), ctx); fail_expr = sexp_pairp(sexp_cdddr(x)) ? sexp_cadddr(x) : SEXP_VOID; - analyze_bind(fail, fail_expr, context); - return sexp_make_cnd(context, test, pass, fail); + analyze_bind(fail, fail_expr, ctx); + return sexp_make_cnd(ctx, test, pass, fail); } -static sexp analyze_define (sexp x, sexp context) { - sexp ref, name, value, env = sexp_context_env(context); +static sexp analyze_define (sexp ctx, sexp x) { + sexp ref, name, value, env = sexp_context_env(ctx); name = (sexp_pairp(sexp_cadr(x)) ? sexp_caadr(x) : sexp_cadr(x)); if (sexp_env_lambda(env) && sexp_lambdap(sexp_env_lambda(env))) { - sexp_push(context, sexp_env_bindings(env), - sexp_cons(context, name, sexp_context_lambda(context))); - sexp_push(context, sexp_lambda_sv(sexp_env_lambda(env)), name); - sexp_push(context, sexp_lambda_locals(sexp_env_lambda(env)), name); - sexp_push(context, sexp_lambda_defs(sexp_env_lambda(env)), x); + sexp_push(ctx, sexp_env_bindings(env), + sexp_cons(ctx, name, sexp_context_lambda(ctx))); + sexp_push(ctx, sexp_lambda_sv(sexp_env_lambda(env)), name); + sexp_push(ctx, sexp_lambda_locals(sexp_env_lambda(env)), name); + sexp_push(ctx, sexp_lambda_defs(sexp_env_lambda(env)), x); return SEXP_VOID; } else { - env_cell_create(context, env, name, SEXP_VOID); + env_cell_create(ctx, env, name, SEXP_VOID); } if (sexp_pairp(sexp_cadr(x))) - value = analyze_lambda(sexp_cons(context, + value = analyze_lambda(ctx, + sexp_cons(ctx, SEXP_VOID, - sexp_cons(context, + sexp_cons(ctx, sexp_cdadr(x), - sexp_cddr(x))), - context); + sexp_cddr(x)))); else - value = analyze(sexp_caddr(x), context); + value = analyze(ctx, sexp_caddr(x)); analyze_check_exception(value); - ref = analyze_var_ref(name, context); + ref = analyze_var_ref(ctx, name); analyze_check_exception(ref); - return sexp_make_set(context, ref, value); + return sexp_make_set(ctx, ref, value); } static sexp analyze_bind_syntax (sexp ls, sexp eval_ctx, sexp bind_ctx) { sexp proc; for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) { - proc = eval_in_context(sexp_cadar(ls), eval_ctx); + proc = eval_in_context(eval_ctx, sexp_cadar(ls)); analyze_check_exception(proc); if (sexp_procedurep(proc)) sexp_push(eval_ctx, @@ -483,99 +531,99 @@ static sexp analyze_bind_syntax (sexp ls, sexp eval_ctx, sexp bind_ctx) { return SEXP_VOID; } -static sexp analyze_define_syntax (sexp x, sexp ctx) { +static sexp analyze_define_syntax (sexp ctx, sexp x) { return analyze_bind_syntax(sexp_list1(ctx, sexp_cdr(x)), ctx, ctx); } -static sexp analyze_let_syntax (sexp x, sexp context) { - sexp env, ctx, tmp; - env = sexp_alloc_type(context, env, SEXP_ENV); - sexp_env_parent(env) = sexp_env_parent(sexp_context_env(context)); - sexp_env_bindings(env) = sexp_env_bindings(sexp_context_env(context)); - ctx = sexp_child_context(context, sexp_context_lambda(context)); - sexp_context_env(ctx) = env; - tmp = analyze_bind_syntax(sexp_cadr(x), context, ctx); +static sexp analyze_let_syntax (sexp ctx, sexp x) { + sexp env, ctx2, tmp; + env = sexp_alloc_type(ctx, env, SEXP_ENV); + sexp_env_parent(env) = sexp_env_parent(sexp_context_env(ctx)); + sexp_env_bindings(env) = sexp_env_bindings(sexp_context_env(ctx)); + ctx2 = sexp_make_child_context(ctx, sexp_context_lambda(ctx)); + sexp_context_env(ctx2) = env; + tmp = analyze_bind_syntax(sexp_cadr(x), ctx, ctx2); analyze_check_exception(tmp); - return analyze_seq(sexp_cddr(x), ctx); + return analyze_seq(ctx2, sexp_cddr(x)); } -static sexp analyze_letrec_syntax (sexp x, sexp context) { - sexp tmp = analyze_bind_syntax(sexp_cadr(x), context, context); +static sexp analyze_letrec_syntax (sexp ctx, sexp x) { + sexp tmp = analyze_bind_syntax(sexp_cadr(x), ctx, ctx); analyze_check_exception(tmp); - return analyze_seq(sexp_cddr(x), context); + return (sexp_exceptionp(tmp) ? tmp : analyze_seq(ctx, sexp_cddr(x))); } -static sexp analyze (sexp x, sexp context) { +static sexp analyze (sexp ctx, sexp x) { sexp op, cell, res; loop: if (sexp_pairp(x)) { - if (sexp_listp(context, x) == SEXP_FALSE) { - res = sexp_compile_error(context, "dotted list in source", x); + if (sexp_listp(ctx, x) == SEXP_FALSE) { + res = sexp_compile_error(ctx, "dotted list in source", x); } else if (sexp_idp(sexp_car(x))) { - cell = env_cell(sexp_context_env(context), sexp_car(x)); + cell = env_cell(sexp_context_env(ctx), sexp_car(x)); if (! cell && sexp_synclop(sexp_car(x))) cell = env_cell(sexp_synclo_env(sexp_car(x)), sexp_synclo_expr(sexp_car(x))); - if (! cell) return analyze_app(x, context); + if (! cell) return analyze_app(ctx, x); op = sexp_cdr(cell); if (sexp_corep(op)) { switch (sexp_core_code(op)) { case CORE_DEFINE: - res = analyze_define(x, context); break; + res = analyze_define(ctx, x); break; case CORE_SET: - res = analyze_set(x, context); break; + res = analyze_set(ctx, x); break; case CORE_LAMBDA: - res = analyze_lambda(x, context); break; + res = analyze_lambda(ctx, x); break; case CORE_IF: - res = analyze_if(x, context); break; + res = analyze_if(ctx, x); break; case CORE_BEGIN: - res = analyze_seq(sexp_cdr(x), context); break; + res = analyze_seq(ctx, sexp_cdr(x)); break; case CORE_QUOTE: - res - = sexp_make_lit(context, sexp_strip_synclos(context, sexp_cadr(x))); + res = sexp_make_lit(ctx, sexp_strip_synclos(ctx, sexp_cadr(x))); break; case CORE_DEFINE_SYNTAX: - res = analyze_define_syntax(x, context); break; + res = analyze_define_syntax(ctx, x); break; case CORE_LET_SYNTAX: - res = analyze_let_syntax(x, context); break; + res = analyze_let_syntax(ctx, x); break; case CORE_LETREC_SYNTAX: - res = analyze_letrec_syntax(x, context); break; + res = analyze_letrec_syntax(ctx, x); break; default: - res = sexp_compile_error(context, "unknown core form", op); break; + res = sexp_compile_error(ctx, "unknown core form", op); break; } } else if (sexp_macrop(op)) { - /* if (in_repl_p) sexp_debug("expand: ", x, context); */ - x = apply(sexp_macro_proc(op), - sexp_list3(context, x, sexp_context_env(context), sexp_macro_env(op)), - sexp_child_context(context, sexp_context_lambda(context))); - /* if (in_repl_p) sexp_debug(" => ", x, context); */ + /* if (in_repl_p) sexp_debug("expand: ", x, ctx); */ + x = apply(sexp_make_child_context(ctx, sexp_context_lambda(ctx)), + sexp_macro_proc(op), + sexp_list3(ctx, x, sexp_context_env(ctx), + sexp_macro_env(op))); + /* if (in_repl_p) sexp_debug(" => ", x, ctx); */ goto loop; } else if (sexp_opcodep(op)) { - res = sexp_length(context, sexp_cdr(x)); + res = sexp_length(ctx, sexp_cdr(x)); if (sexp_unbox_integer(res) < sexp_opcode_num_args(op)) { - res = sexp_compile_error(context, "not enough args for opcode", x); + res = sexp_compile_error(ctx, "not enough args for opcode", x); } else if ((sexp_unbox_integer(res) > sexp_opcode_num_args(op)) && (! sexp_opcode_variadic_p(op))) { - res = sexp_compile_error(context, "too many args for opcode", x); + res = sexp_compile_error(ctx, "too many args for opcode", x); } else { - res = analyze_app(sexp_cdr(x), context); + res = analyze_app(ctx, sexp_cdr(x)); analyze_check_exception(res); - sexp_push(context, res, op); + sexp_push(ctx, res, op); } } else { - res = analyze_app(x, context); + res = analyze_app(ctx, x); } } else { - res = analyze_app(x, context); + res = analyze_app(ctx, x); } } else if (sexp_idp(x)) { - res = analyze_var_ref(x, context); + res = analyze_var_ref(ctx, x); } else if (sexp_synclop(x)) { - context = sexp_child_context(context, sexp_context_lambda(context)); - sexp_context_env(context) = sexp_synclo_env(x); - sexp_context_fv(context) = sexp_append2(context, - sexp_synclo_free_vars(x), - sexp_context_fv(context)); + ctx = sexp_make_child_context(ctx, sexp_context_lambda(ctx)); + sexp_context_env(ctx) = sexp_synclo_env(x); + sexp_context_fv(ctx) = sexp_append2(ctx, + sexp_synclo_free_vars(x), + sexp_context_fv(ctx)); x = sexp_synclo_expr(x); goto loop; } else { @@ -584,194 +632,193 @@ static sexp analyze (sexp x, sexp context) { return res; } -static sexp_sint_t sexp_context_make_label (sexp context) { - sexp_sint_t label = sexp_context_pos(context); - sexp_context_pos(context) += sizeof(sexp_uint_t); +static sexp_sint_t sexp_context_make_label (sexp ctx) { + sexp_sint_t label = sexp_context_pos(ctx); + sexp_context_pos(ctx) += sizeof(sexp_uint_t); return label; } -static void sexp_context_patch_label (sexp context, sexp_sint_t label) { - sexp bc = sexp_context_bc(context); +static void sexp_context_patch_label (sexp ctx, sexp_sint_t label) { + sexp bc = sexp_context_bc(ctx); unsigned char *data = sexp_bytecode_data(bc)+label; - *((sexp_sint_t*)data) = sexp_context_pos(context)-label; + *((sexp_sint_t*)data) = sexp_context_pos(ctx)-label; } -static sexp finalize_bytecode (sexp context) { - emit(OP_RET, context); - shrink_bcode(context, sexp_context_pos(context)); - return sexp_context_bc(context); +static sexp finalize_bytecode (sexp ctx) { + emit(ctx, OP_RET); + shrink_bcode(ctx, sexp_context_pos(ctx)); + return sexp_context_bc(ctx); } -static void generate_lit (sexp value, sexp context) { - emit_push(value, context); +static void generate_lit (sexp ctx, sexp value) { + emit_push(ctx, value); } -static void generate_seq (sexp app, sexp context) { +static void generate_seq (sexp ctx, sexp app) { sexp head=app, tail=sexp_cdr(app); - sexp_uint_t tailp = sexp_context_tailp(context); - sexp_context_tailp(context) = 0; + sexp_uint_t tailp = sexp_context_tailp(ctx); + sexp_context_tailp(ctx) = 0; for ( ; sexp_pairp(tail); head=tail, tail=sexp_cdr(tail)) if (sexp_pointerp(sexp_car(head)) && (! sexp_litp(sexp_car(head)))) { - generate(sexp_car(head), context); - emit(OP_DROP, context); - sexp_context_depth(context)--; + generate(ctx, sexp_car(head)); + emit(ctx, OP_DROP); + sexp_context_depth(ctx)--; } - sexp_context_tailp(context) = tailp; - generate(sexp_car(head), context); + sexp_context_tailp(ctx) = tailp; + generate(ctx, sexp_car(head)); } -static void generate_cnd (sexp cnd, sexp context) { - sexp_sint_t label1, label2, tailp=sexp_context_tailp(context); - sexp_context_tailp(context) = 0; - generate(sexp_cnd_test(cnd), context); - sexp_context_tailp(context) = tailp; - emit(OP_JUMP_UNLESS, context); - sexp_context_depth(context)--; - label1 = sexp_context_make_label(context); - generate(sexp_cnd_pass(cnd), context); - emit(OP_JUMP, context); - sexp_context_depth(context)--; - label2 = sexp_context_make_label(context); - sexp_context_patch_label(context, label1); - generate(sexp_cnd_fail(cnd), context); - sexp_context_patch_label(context, label2); +static void generate_cnd (sexp ctx, sexp cnd) { + sexp_sint_t label1, label2, tailp=sexp_context_tailp(ctx); + sexp_context_tailp(ctx) = 0; + generate(ctx, sexp_cnd_test(cnd)); + sexp_context_tailp(ctx) = tailp; + emit(ctx, OP_JUMP_UNLESS); + sexp_context_depth(ctx)--; + label1 = sexp_context_make_label(ctx); + generate(ctx, sexp_cnd_pass(cnd)); + emit(ctx, OP_JUMP); + sexp_context_depth(ctx)--; + label2 = sexp_context_make_label(ctx); + sexp_context_patch_label(ctx, label1); + generate(ctx, sexp_cnd_fail(cnd)); + sexp_context_patch_label(ctx, label2); } -static void generate_non_global_ref (sexp name, sexp cell, sexp lambda, - sexp fv, sexp context, int unboxp) { +static void generate_non_global_ref (sexp ctx, sexp name, sexp cell, + sexp lambda, sexp fv, int unboxp) { sexp_uint_t i; sexp loc = sexp_cdr(cell); if (loc == lambda && sexp_lambdap(lambda)) { /* local ref */ - emit(OP_LOCAL_REF, context); - emit_word(sexp_param_index(lambda, name), context); + emit(ctx, OP_LOCAL_REF); + emit_word(ctx, sexp_param_index(lambda, name)); } else { /* closure ref */ for (i=0; sexp_pairp(fv); fv=sexp_cdr(fv), i++) if ((name == sexp_ref_name(sexp_car(fv))) && (loc == sexp_ref_loc(sexp_car(fv)))) break; - emit(OP_CLOSURE_REF, context); - emit_word(i, context); + emit(ctx, OP_CLOSURE_REF); + emit_word(ctx, i); } - if (unboxp && (sexp_memq(context, name, sexp_lambda_sv(loc)) != SEXP_FALSE)) - emit(OP_CDR, context); - sexp_context_depth(context)++; + if (unboxp && (sexp_memq(ctx, name, sexp_lambda_sv(loc)) != SEXP_FALSE)) + emit(ctx, OP_CDR); + sexp_context_depth(ctx)++; } -static void generate_ref (sexp ref, sexp context, int unboxp) { +static void generate_ref (sexp ctx, sexp ref, int unboxp) { sexp lam; if (! sexp_lambdap(sexp_ref_loc(ref))) { /* global ref */ if (unboxp) { - emit((sexp_cdr(sexp_ref_cell(ref)) == SEXP_UNDEF) - ? OP_GLOBAL_REF : OP_GLOBAL_KNOWN_REF, - context); - emit_word((sexp_uint_t)sexp_ref_cell(ref), context); + emit(ctx, + (sexp_cdr(sexp_ref_cell(ref)) == SEXP_UNDEF) + ? OP_GLOBAL_REF : OP_GLOBAL_KNOWN_REF); + emit_word(ctx, (sexp_uint_t)sexp_ref_cell(ref)); } else - emit_push(sexp_ref_cell(ref), context); + emit_push(ctx, sexp_ref_cell(ref)); } else { - lam = sexp_context_lambda(context); - generate_non_global_ref(sexp_ref_name(ref), sexp_ref_cell(ref), lam, - sexp_lambda_fv(lam), context, unboxp); + lam = sexp_context_lambda(ctx); + generate_non_global_ref(ctx, sexp_ref_name(ref), sexp_ref_cell(ref), + lam, sexp_lambda_fv(lam), unboxp); } } -static void generate_set (sexp set, sexp context) { +static void generate_set (sexp ctx, sexp set) { sexp ref = sexp_set_var(set), lambda; /* compile the value */ - sexp_context_tailp(context) = 0; + sexp_context_tailp(ctx) = 0; if (sexp_lambdap(sexp_set_value(set))) sexp_lambda_name(sexp_set_value(set)) = sexp_ref_name(ref); - generate(sexp_set_value(set), context); + generate(ctx, sexp_set_value(set)); if (! sexp_lambdap(sexp_ref_loc(ref))) { /* global vars are set directly */ - emit_push(sexp_ref_cell(ref), context); - emit(OP_SET_CDR, context); + emit_push(ctx, sexp_ref_cell(ref)); + emit(ctx, OP_SET_CDR); } else { lambda = sexp_ref_loc(ref); - if (sexp_memq(context, sexp_ref_name(ref), sexp_lambda_sv(lambda)) + if (sexp_memq(ctx, sexp_ref_name(ref), sexp_lambda_sv(lambda)) != SEXP_FALSE) { /* stack or closure mutable vars are boxed */ - generate_ref(ref, context, 0); - emit(OP_SET_CDR, context); + generate_ref(ctx, ref, 0); + emit(ctx, OP_SET_CDR); } else { /* internally defined variable */ - emit(OP_LOCAL_SET, context); - emit_word(sexp_param_index(lambda, sexp_ref_name(ref)), context); + emit(ctx, OP_LOCAL_SET); + emit_word(ctx, sexp_param_index(lambda, sexp_ref_name(ref))); } } - sexp_context_depth(context)--; + sexp_context_depth(ctx)--; } -static void generate_opcode_app (sexp app, sexp context) { +static void generate_opcode_app (sexp ctx, sexp app) { sexp ls, op = sexp_car(app); sexp_sint_t i, num_args; - num_args = sexp_unbox_integer(sexp_length(context, sexp_cdr(app))); - sexp_context_tailp(context) = 0; + num_args = sexp_unbox_integer(sexp_length(ctx, sexp_cdr(app))); + sexp_context_tailp(ctx) = 0; /* maybe push the default for an optional argument */ if ((num_args == sexp_opcode_num_args(op)) && sexp_opcode_variadic_p(op) && sexp_opcode_default(op) && (sexp_opcode_class(op) != OPC_PARAMETER)) { - emit_push(sexp_opcode_default(op), context); + emit_push(ctx, sexp_opcode_default(op)); if (sexp_opcode_opt_param_p(op)) - emit(OP_CDR, context); - sexp_context_depth(context)++; + emit(ctx, OP_CDR); + sexp_context_depth(ctx)++; num_args++; } /* push the arguments onto the stack */ ls = ((sexp_opcode_inverse(op) && (sexp_opcode_class(op) != OPC_ARITHMETIC_INV)) - ? sexp_cdr(app) : sexp_reverse(context, sexp_cdr(app))); + ? sexp_cdr(app) : sexp_reverse(ctx, sexp_cdr(app))); for ( ; sexp_pairp(ls); ls = sexp_cdr(ls)) - generate(sexp_car(ls), context); + generate(ctx, sexp_car(ls)); /* emit the actual operator call */ switch (sexp_opcode_class(op)) { case OPC_ARITHMETIC: if (num_args > 1) - emit(sexp_opcode_code(op), context); + emit(ctx, sexp_opcode_code(op)); break; case OPC_ARITHMETIC_INV: - emit((num_args == 1) ? sexp_opcode_inverse(op) - : sexp_opcode_code(op), context); + emit(ctx, (num_args==1) ? sexp_opcode_inverse(op) : sexp_opcode_code(op)); break; case OPC_ARITHMETIC_CMP: if (num_args > 2) { - emit(OP_STACK_REF, context); - emit_word(2, context); - emit(OP_STACK_REF, context); - emit_word(2, context); - emit(sexp_opcode_code(op), context); - emit(OP_AND, context); + emit(ctx, OP_STACK_REF); + emit_word(ctx, 2); + emit(ctx, OP_STACK_REF); + emit_word(ctx, 2); + emit(ctx, sexp_opcode_code(op)); + emit(ctx, OP_AND); for (i=num_args-2; i>0; i--) { - emit(OP_STACK_REF, context); - emit_word(3, context); - emit(OP_STACK_REF, context); - emit_word(3, context); - emit(sexp_opcode_code(op), context); - emit(OP_AND, context); - emit(OP_AND, context); + emit(ctx, OP_STACK_REF); + emit_word(ctx, 3); + emit(ctx, OP_STACK_REF); + emit_word(ctx, 3); + emit(ctx, sexp_opcode_code(op)); + emit(ctx, OP_AND); + emit(ctx, OP_AND); } } else - emit(sexp_opcode_code(op), context); + emit(ctx, sexp_opcode_code(op)); break; case OPC_FOREIGN: case OPC_TYPE_PREDICATE: /* push the funtion pointer for foreign calls */ - emit(sexp_opcode_code(op), context); + emit(ctx, sexp_opcode_code(op)); if (sexp_opcode_data(op)) - emit_word((sexp_uint_t)sexp_opcode_data(op), context); + emit_word(ctx, (sexp_uint_t)sexp_opcode_data(op)); break; case OPC_PARAMETER: - emit_push(sexp_opcode_default(op), context); - emit((num_args == 0 ? OP_CDR : OP_SET_CDR), context); + emit_push(ctx, sexp_opcode_default(op)); + emit(ctx, ((num_args == 0) ? OP_CDR : OP_SET_CDR)); break; default: - emit(sexp_opcode_code(op), context); + emit(ctx, sexp_opcode_code(op)); } /* emit optional folding of operator */ @@ -779,130 +826,123 @@ static void generate_opcode_app (sexp app, sexp context) { && (sexp_opcode_class(op) == OPC_ARITHMETIC || sexp_opcode_class(op) == OPC_ARITHMETIC_INV)) for (i=num_args-2; i>0; i--) - emit(sexp_opcode_code(op), context); + emit(ctx, sexp_opcode_code(op)); - sexp_context_depth(context) -= (num_args-1); + sexp_context_depth(ctx) -= (num_args-1); } -static void generate_general_app (sexp app, sexp context) { +static void generate_general_app (sexp ctx, sexp app) { sexp ls; - sexp_uint_t len = sexp_unbox_integer(sexp_length(context, sexp_cdr(app))), - tailp = sexp_context_tailp(context); + sexp_uint_t len = sexp_unbox_integer(sexp_length(ctx, sexp_cdr(app))), + tailp = sexp_context_tailp(ctx); /* push the arguments onto the stack */ - sexp_context_tailp(context) = 0; - for (ls = sexp_reverse(context, sexp_cdr(app)); sexp_pairp(ls); + sexp_context_tailp(ctx) = 0; + for (ls = sexp_reverse(ctx, sexp_cdr(app)); sexp_pairp(ls); ls = sexp_cdr(ls)) - generate(sexp_car(ls), context); + generate(ctx, sexp_car(ls)); /* push the operator onto the stack */ - generate(sexp_car(app), context); + generate(ctx, sexp_car(app)); /* maybe overwrite the current frame */ - emit((tailp ? OP_TAIL_CALL : OP_CALL), context); - emit_word((sexp_uint_t)sexp_make_integer(len), context); + emit(ctx, (tailp ? OP_TAIL_CALL : OP_CALL)); + emit_word(ctx, (sexp_uint_t)sexp_make_integer(len)); - sexp_context_depth(context) -= len; + sexp_context_depth(ctx) -= len; } -static void generate_app (sexp app, sexp context) { +static void generate_app (sexp ctx, sexp app) { if (sexp_opcodep(sexp_car(app))) - generate_opcode_app(app, context); + generate_opcode_app(ctx, app); else - generate_general_app(app, context); + generate_general_app(ctx, app); } -static void generate_lambda (sexp lambda, sexp context) { - sexp fv, ls, ctx, flags, bc, len, ref, vec, prev_lambda, prev_fv; +static void generate_lambda (sexp ctx, sexp lambda) { + sexp fv, ls, ctx2, flags, bc, len, ref, vec, prev_lambda, prev_fv; sexp_uint_t k; - prev_lambda = sexp_context_lambda(context); + prev_lambda = sexp_context_lambda(ctx); prev_fv = sexp_lambdap(prev_lambda) ? sexp_lambda_fv(prev_lambda) : SEXP_NULL; fv = sexp_lambda_fv(lambda); - ctx = sexp_make_context(context, - sexp_context_stack(context), - sexp_context_env(context)); - sexp_context_lambda(ctx) = lambda; + ctx2 = sexp_make_context(ctx, + sexp_context_stack(ctx), + sexp_context_env(ctx)); + sexp_context_lambda(ctx2) = lambda; /* allocate space for local vars */ for (ls=sexp_lambda_locals(lambda); sexp_pairp(ls); ls=sexp_cdr(ls)) - emit_push(SEXP_VOID, ctx); + emit_push(ctx2, SEXP_VOID); /* box mutable vars */ for (ls=sexp_lambda_sv(lambda); sexp_pairp(ls); ls=sexp_cdr(ls)) { k = sexp_param_index(lambda, sexp_car(ls)); if (k >= 0) { - emit(OP_LOCAL_REF, ctx); - emit_word(k, ctx); - emit_push(sexp_car(ls), ctx); - emit(OP_CONS, ctx); - emit(OP_LOCAL_SET, ctx); - emit_word(k, ctx); - emit(OP_DROP, ctx); + emit(ctx2, OP_LOCAL_REF); + emit_word(ctx2, k); + emit_push(ctx2, sexp_car(ls)); + emit(ctx2, OP_CONS); + emit(ctx2, OP_LOCAL_SET); + emit_word(ctx2, k); + emit(ctx2, OP_DROP); } } - sexp_context_tailp(ctx) = 1; - generate(sexp_lambda_body(lambda), ctx); - flags = sexp_make_integer((sexp_listp(context, sexp_lambda_params(lambda)) + sexp_context_tailp(ctx2) = 1; + generate(ctx2, sexp_lambda_body(lambda)); + flags = sexp_make_integer((sexp_listp(ctx, sexp_lambda_params(lambda)) == SEXP_FALSE) ? 1 : 0); - len = sexp_length(context, sexp_lambda_params(lambda)); - bc = finalize_bytecode(ctx); + len = sexp_length(ctx, sexp_lambda_params(lambda)); + bc = finalize_bytecode(ctx2); sexp_bytecode_name(bc) = sexp_lambda_name(lambda); if (sexp_nullp(fv)) { /* shortcut, no free vars */ - vec = sexp_make_vector(context, sexp_make_integer(0), SEXP_VOID); - generate_lit(sexp_make_procedure(context, flags, len, bc, vec), context); + vec = sexp_make_vector(ctx, sexp_make_integer(0), SEXP_VOID); + generate_lit(ctx, sexp_make_procedure(ctx, flags, len, bc, vec)); } else { /* push the closed vars */ - emit_push(SEXP_VOID, context); - emit_push(sexp_length(context, fv), context); - emit(OP_MAKE_VECTOR, context); - sexp_context_depth(context)--; + emit_push(ctx, SEXP_VOID); + emit_push(ctx, sexp_length(ctx, fv)); + emit(ctx, OP_MAKE_VECTOR); + sexp_context_depth(ctx)--; for (k=0; sexp_pairp(fv); fv=sexp_cdr(fv), k++) { ref = sexp_car(fv); - generate_non_global_ref(sexp_ref_name(ref), sexp_ref_cell(ref), - prev_lambda, prev_fv, context, 0); - emit_push(sexp_make_integer(k), context); - emit(OP_STACK_REF, context); - emit_word(3, context); - emit(OP_VECTOR_SET, context); - emit(OP_DROP, context); - sexp_context_depth(context)--; + generate_non_global_ref(ctx, sexp_ref_name(ref), sexp_ref_cell(ref), + prev_lambda, prev_fv, 0); + emit_push(ctx, sexp_make_integer(k)); + emit(ctx, OP_STACK_REF); + emit_word(ctx, 3); + emit(ctx, OP_VECTOR_SET); + emit(ctx, OP_DROP); + sexp_context_depth(ctx)--; } /* push the additional procedure info and make the closure */ - emit_push(bc, context); - emit_push(len, context); - emit_push(flags, context); - emit(OP_MAKE_PROCEDURE, context); + emit_push(ctx, bc); + emit_push(ctx, len); + emit_push(ctx, flags); + emit(ctx, OP_MAKE_PROCEDURE); } } -static void generate (sexp x, sexp context) { +static void generate (sexp ctx, sexp x) { if (sexp_pointerp(x)) { switch (sexp_pointer_tag(x)) { case SEXP_PAIR: - generate_app(x, context); - break; + generate_app(ctx, x); break; case SEXP_LAMBDA: - generate_lambda(x, context); - break; + generate_lambda(ctx, x); break; case SEXP_CND: - generate_cnd(x, context); - break; + generate_cnd(ctx, x); break; case SEXP_REF: - generate_ref(x, context, 1); - break; + generate_ref(ctx, x, 1); break; case SEXP_SET: - generate_set(x, context); - break; + generate_set(ctx, x); break; case SEXP_SEQ: - generate_seq(sexp_seq_ls(x), context); - break; + generate_seq(ctx, sexp_seq_ls(x)); break; case SEXP_LIT: - generate_lit(sexp_lit_value(x), context); - break; + generate_lit(ctx, sexp_lit_value(x)); break; default: - generate_lit(x, context); + generate_lit(ctx, x); } } else { - generate_lit(x, context); + generate_lit(ctx, x); } } @@ -988,7 +1028,7 @@ static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i, sexp env, sexp_context_top(context) = top; for (ls=params, refs=SEXP_NULL; sexp_pairp(ls); ls=sexp_cdr(ls)) sexp_push(context, refs, sexp_make_ref(context, sexp_car(ls), env_cell(env, sexp_car(ls)))); - generate_opcode_app(sexp_cons(context, op, sexp_reverse(context, refs)), context); + generate_opcode_app(context, sexp_cons(context, op, sexp_reverse(context, refs))); bc = finalize_bytecode(context); sexp_bytecode_name(bc) = sexp_c_string(ctx, sexp_opcode_name(op), -1); res = sexp_make_procedure(ctx, sexp_make_integer(0), sexp_make_integer(i), @@ -1214,7 +1254,7 @@ sexp vm (sexp self, sexp context, sexp* stack, sexp_sint_t top) { break; case OP_EVAL: sexp_context_top(context) = top; - _ARG1 = eval_in_context(_ARG1, context); + _ARG1 = eval_in_context(context, _ARG1); sexp_check_exception(); break; case OP_JUMP_UNLESS: @@ -1625,17 +1665,17 @@ static void sexp_warn_undefs (sexp from, sexp to, sexp out) { } sexp sexp_load (sexp ctx, sexp source, sexp env) { - sexp x, res, in, tmp, out, context = sexp_make_context(ctx, NULL, env); + sexp x, res, in, tmp, out, ctx2 = sexp_make_context(ctx, NULL, env); out = env_global_ref(env, the_cur_err_symbol, SEXP_FALSE); tmp = sexp_env_bindings(env); - sexp_context_tailp(context) = 0; + sexp_context_tailp(ctx2) = 0; in = sexp_open_input_file(ctx, source); if (sexp_exceptionp(in)) { sexp_print_exception(ctx, in, out); return in; } while ((x=sexp_read(ctx, in)) != (sexp) SEXP_EOF) { - res = eval_in_context(x, context); + res = eval_in_context(ctx2, x); if (sexp_exceptionp(res)) break; } @@ -1777,7 +1817,12 @@ static sexp sexp_copy_opcode (sexp ctx, sexp op) { static sexp sexp_make_standard_env (sexp ctx, sexp version) { sexp_uint_t i; - sexp e = sexp_make_null_env(ctx, version), op, cell, sym; + sexp cell, sym; + sexp_gc_var(ctx, e, s_e); + sexp_gc_var(ctx, op, s_op); + sexp_gc_preserve(ctx, e, s_e); + sexp_gc_preserve(ctx, op, s_op); + e = sexp_make_null_env(ctx, version); for (i=0; i<(sizeof(opcodes)/sizeof(opcodes[0])); i++) { op = &opcodes[i]; if (sexp_opcode_opt_param_p(op) && sexp_opcode_default(op)) { @@ -1788,73 +1833,76 @@ static sexp sexp_make_standard_env (sexp ctx, sexp version) { } env_define(ctx, e, sexp_intern(ctx, sexp_opcode_name(op)), op); } - env_define(ctx, e, the_cur_in_symbol, sexp_make_input_port(ctx, stdin, NULL)); - env_define(ctx, e, the_cur_out_symbol, sexp_make_output_port(ctx, stdout, NULL)); - env_define(ctx, e, the_cur_err_symbol, sexp_make_output_port(ctx, stderr, NULL)); + env_define(ctx, e, the_cur_in_symbol, + sexp_make_input_port(ctx, stdin, NULL)); + env_define(ctx, e, the_cur_out_symbol, + sexp_make_output_port(ctx, stdout, NULL)); + env_define(ctx, e, the_cur_err_symbol, + sexp_make_output_port(ctx, stderr, NULL)); env_define(ctx, e, the_interaction_env_symbol, e); + sexp_gc_release(ctx, e, s_e); + sexp_gc_release(ctx, op, s_op); return e; } /************************** eval interface ****************************/ -sexp apply(sexp proc, sexp args, sexp context) { - sexp *stack = sexp_context_stack(context), ls; - sexp_sint_t top = sexp_context_top(context), offset; - offset = top + sexp_unbox_integer(sexp_length(context, args)); +sexp apply(sexp ctx, sexp proc, sexp args) { + sexp *stack = sexp_context_stack(ctx), ls; + sexp_sint_t top = sexp_context_top(ctx), offset; + offset = top + sexp_unbox_integer(sexp_length(ctx, args)); for (ls=args; sexp_pairp(ls); ls=sexp_cdr(ls), top++) stack[--offset] = sexp_car(ls); stack[top] = sexp_make_integer(top); top++; stack[top++] = sexp_make_integer(sexp_bytecode_data(final_resumer)); - stack[top++] = sexp_make_vector(context, 0, SEXP_VOID); + stack[top++] = sexp_make_vector(ctx, 0, SEXP_VOID); stack[top++] = sexp_make_integer(0); - return vm(proc, context, stack, top); + return vm(proc, ctx, stack, top); } -sexp compile (sexp x, sexp context) { - sexp ast, ctx; - analyze_bind(ast, x, context); - free_vars(context, ast, SEXP_NULL); /* should return SEXP_NULL */ - ctx = sexp_make_context(context, - sexp_context_stack(context), - sexp_context_env(context)); - generate(ast, ctx); - return sexp_make_procedure(context, sexp_make_integer(0), +sexp compile (sexp ctx, sexp x) { + sexp ast, ctx2; + analyze_bind(ast, x, ctx); + free_vars(ctx, ast, SEXP_NULL); /* should return SEXP_NULL */ + ctx2 = sexp_make_context(ctx, sexp_context_stack(ctx), sexp_context_env(ctx)); + generate(ctx2, ast); + return sexp_make_procedure(ctx, sexp_make_integer(0), sexp_make_integer(0), - finalize_bytecode(ctx), - sexp_make_vector(context, 0, SEXP_VOID)); + finalize_bytecode(ctx2), + sexp_make_vector(ctx, 0, SEXP_VOID)); } -sexp eval_in_context (sexp obj, sexp context) { - sexp thunk = compile(obj, context); +sexp eval_in_context (sexp ctx, sexp obj) { + sexp thunk = compile(ctx, obj); if (sexp_exceptionp(thunk)) { - sexp_print_exception(context, thunk, - env_global_ref(sexp_context_env(context), + sexp_print_exception(ctx, thunk, + env_global_ref(sexp_context_env(ctx), the_cur_err_symbol, SEXP_FALSE)); return thunk; } - return apply(thunk, SEXP_NULL, context); + return apply(ctx, thunk, SEXP_NULL); } sexp eval (sexp obj, sexp env) { - sexp context = sexp_make_context(NULL, NULL, NULL); - sexp_context_env(context) = env; - return eval_in_context(obj, context); + sexp ctx = sexp_make_context(NULL, NULL, NULL); + sexp_context_env(ctx) = env; + return eval_in_context(ctx, obj); } void scheme_init () { - sexp context; + sexp ctx; if (! scheme_initialized_p) { scheme_initialized_p = 1; sexp_init(); - context = sexp_make_context(NULL, NULL, NULL); - the_compile_error_symbol = sexp_intern(context, "compile"); - the_err_handler_symbol = sexp_intern(context, "*current-exception-handler*"); - the_cur_in_symbol = sexp_intern(context, "*current-input-port*"); - the_cur_out_symbol = sexp_intern(context, "*current-output-port*"); - the_cur_err_symbol = sexp_intern(context, "*current-error-port*"); - the_interaction_env_symbol = sexp_intern(context, "*interaction-environment*"); + ctx = sexp_make_context(NULL, NULL, NULL); + the_compile_error_symbol = sexp_intern(ctx, "compile"); + the_err_handler_symbol = sexp_intern(ctx, "*current-exception-handler*"); + the_cur_in_symbol = sexp_intern(ctx, "*current-input-port*"); + the_cur_out_symbol = sexp_intern(ctx, "*current-output-port*"); + the_cur_err_symbol = sexp_intern(ctx, "*current-error-port*"); + the_interaction_env_symbol = sexp_intern(ctx, "*interaction-environment*"); #if USE_BOEHM GC_add_roots((char*)&continuation_resumer, ((char*)&continuation_resumer)+sizeof(continuation_resumer)+1); @@ -1862,10 +1910,10 @@ void scheme_init () { ((char*)&final_resumer)+sizeof(continuation_resumer)+1); GC_add_roots((char*)&opcodes, ((char*)&opcodes)+sizeof(opcodes)+1); #endif - emit(OP_RESUMECC, context); - continuation_resumer = finalize_bytecode(context); - context = sexp_child_context(context, NULL); - emit(OP_DONE, context); - final_resumer = finalize_bytecode(context); + emit(ctx, OP_RESUMECC); + continuation_resumer = finalize_bytecode(ctx); + ctx = sexp_make_child_context(ctx, NULL); + emit(ctx, OP_DONE); + final_resumer = finalize_bytecode(ctx); } } diff --git a/gc.c b/gc.c index 139fd7eb..2d1ecca0 100644 --- a/gc.c +++ b/gc.c @@ -155,7 +155,7 @@ sexp sexp_gc (sexp ctx) { sexp_gc_mark(ctx) = 1; if (sexp_context_bc(ctx)) sexp_mark(sexp_context_bc(ctx)); sexp_mark(sexp_context_env(ctx)); - for (saves=&(sexp_context_saves(ctx)); saves; saves=saves->next) + for (saves=sexp_context_saves(ctx); saves; saves=saves->next) if (saves->var) sexp_mark(*(saves->var)); } return sexp_sweep(ctx); diff --git a/main.c b/main.c index 4a36ef40..830e89f7 100644 --- a/main.c +++ b/main.c @@ -1,24 +1,24 @@ #include "eval.c" -void repl (sexp context) { +void repl (sexp ctx) { sexp obj, tmp, res, env, in, out, err; - env = sexp_context_env(context); - sexp_context_tracep(context) = 1; + env = sexp_context_env(ctx); + sexp_context_tracep(ctx) = 1; in = env_global_ref(env, the_cur_in_symbol, SEXP_FALSE); out = env_global_ref(env, the_cur_out_symbol, SEXP_FALSE); err = env_global_ref(env, the_cur_err_symbol, SEXP_FALSE); while (1) { sexp_write_string("> ", out); sexp_flush(out); - obj = sexp_read(context, in); + obj = sexp_read(ctx, in); if (obj == SEXP_EOF) break; if (sexp_exceptionp(obj)) { - sexp_print_exception(context, obj, err); + sexp_print_exception(ctx, obj, err); } else { tmp = sexp_env_bindings(env); - res = eval_in_context(obj, context); + res = eval_in_context(ctx, obj); #if USE_WARN_UNDEFS sexp_warn_undefs(sexp_env_bindings(env), tmp, err); #endif @@ -31,33 +31,33 @@ void repl (sexp context) { } void run_main (int argc, char **argv) { - sexp env, out=NULL, res, context, perr_cell, err_cell, err_handler; + sexp env, out=NULL, res, ctx, perr_cell, err_cell, err_handler; sexp_uint_t i, quit=0, init_loaded=0; - context = sexp_make_context(NULL, NULL, NULL); - env = sexp_make_standard_env(context, sexp_make_integer(5)); - env_define(context, env, the_interaction_env_symbol, env); + ctx = sexp_make_context(NULL, NULL, NULL); + env = sexp_make_standard_env(ctx, sexp_make_integer(5)); + env_define(ctx, env, the_interaction_env_symbol, env); out = env_global_ref(env, the_cur_out_symbol, SEXP_FALSE); err_cell = env_cell(env, the_cur_err_symbol); - perr_cell = env_cell(env, sexp_intern(context, "print-exception")); - sexp_context_env(context) = env; - sexp_context_tailp(context) = 0; + perr_cell = env_cell(env, sexp_intern(ctx, "print-exception")); + sexp_context_env(ctx) = env; + sexp_context_tailp(ctx) = 0; if (err_cell && perr_cell && sexp_opcodep(sexp_cdr(perr_cell))) { - emit(OP_GLOBAL_KNOWN_REF, context); - emit_word((sexp_uint_t)err_cell, context); - emit(OP_LOCAL_REF, context); - emit_word(0, context); - emit(OP_FCALL2, context); - emit_word((sexp_uint_t)sexp_opcode_data(sexp_cdr(perr_cell)), context); + emit(ctx, OP_GLOBAL_KNOWN_REF); + emit_word(ctx, (sexp_uint_t)err_cell); + emit(ctx, OP_LOCAL_REF); + emit_word(ctx, 0); + emit(ctx, OP_FCALL2); + emit_word(ctx, (sexp_uint_t)sexp_opcode_data(sexp_cdr(perr_cell))); } - emit_push(SEXP_VOID, context); - emit(OP_DONE, context); - err_handler = sexp_make_procedure(context, + emit_push(ctx, SEXP_VOID); + emit(ctx, OP_DONE); + err_handler = sexp_make_procedure(ctx, sexp_make_integer(0), sexp_make_integer(0), - finalize_bytecode(context), - sexp_make_vector(context, 0, SEXP_VOID)); - env_define(context, env, the_err_handler_symbol, err_handler); + finalize_bytecode(ctx), + sexp_make_vector(ctx, 0, SEXP_VOID)); + env_define(ctx, env, the_err_handler_symbol, err_handler); /* parse options */ for (i=1; i < argc && argv[i][0] == '-'; i++) { @@ -66,12 +66,12 @@ void run_main (int argc, char **argv) { case 'e': case 'p': if (! init_loaded++) - sexp_load(context, sexp_c_string(context, sexp_init_file, -1), env); - res = sexp_read_from_string(context, argv[i+1]); + sexp_load(ctx, sexp_c_string(ctx, sexp_init_file, -1), env); + res = sexp_read_from_string(ctx, argv[i+1]); if (! sexp_exceptionp(res)) - res = eval_in_context(res, context); + res = eval_in_context(ctx, res); if (sexp_exceptionp(res)) { - sexp_print_exception(context, res, out); + sexp_print_exception(ctx, res, out); } else if (argv[i][1] == 'p') { sexp_write(res, out); sexp_write_char('\n', out); @@ -82,8 +82,8 @@ void run_main (int argc, char **argv) { #endif case 'l': if (! init_loaded++) - sexp_load(context, sexp_c_string(context, sexp_init_file, -1), env); - sexp_load(context, sexp_c_string(context, argv[++i], -1), env); + sexp_load(ctx, sexp_c_string(ctx, sexp_init_file, -1), env); + sexp_load(ctx, sexp_c_string(ctx, argv[++i], -1), env); break; case 'q': init_loaded = 1; @@ -95,12 +95,12 @@ void run_main (int argc, char **argv) { if (! quit) { if (! init_loaded) - sexp_load(context, sexp_c_string(context, sexp_init_file, -1), env); + sexp_load(ctx, sexp_c_string(ctx, sexp_init_file, -1), env); if (i < argc) for ( ; i < argc; i++) - sexp_load(context, sexp_c_string(context, argv[i], -1), env); + sexp_load(ctx, sexp_c_string(ctx, argv[i], -1), env); else - repl(context); + repl(ctx); } } diff --git a/sexp.c b/sexp.c index 78532be1..5b39a125 100644 --- a/sexp.c +++ b/sexp.c @@ -237,7 +237,7 @@ sexp sexp_nreverse (sexp ctx, sexp ls) { if (ls == SEXP_NULL) { return ls; } else if (! sexp_pairp(ls)) { - return SEXP_ERROR; + return SEXP_NULL; /* XXXX return an exception */ } else { b = ls; a = sexp_cdr(ls); @@ -748,8 +748,6 @@ void sexp_write (sexp obj, sexp out) { case (sexp_uint_t) SEXP_UNDEF: case (sexp_uint_t) SEXP_VOID: sexp_write_string("#", out); break; - case (sexp_uint_t) SEXP_ERROR: - sexp_write_string("#", out); break; default: sexp_printf(out, "#", obj); } @@ -878,9 +876,13 @@ sexp sexp_read_number(sexp ctx, sexp in, int base) { } sexp sexp_read_raw (sexp ctx, sexp in) { - sexp res, tmp, tmp2; char *str; int c1, c2; + sexp tmp2; + sexp_gc_var(ctx, res, s_res); + sexp_gc_var(ctx, tmp, s_tmp); + sexp_gc_preserve(ctx, res, s_res); + sexp_gc_preserve(ctx, tmp, s_tmp); scan_loop: switch (c1 = sexp_read_char(in)) { @@ -924,34 +926,41 @@ sexp sexp_read_raw (sexp ctx, sexp in) { case '(': res = SEXP_NULL; tmp = sexp_read_raw(ctx, in); - while ((tmp != SEXP_ERROR) && (tmp != SEXP_EOF) && (tmp != SEXP_CLOSE)) { - if (tmp == SEXP_RAWDOT) { + while ((tmp != SEXP_EOF) && (tmp != SEXP_CLOSE) && (tmp != SEXP_RAWDOT)) { + res = sexp_cons(ctx, tmp, res); + tmp = sexp_read_raw(ctx, in); + if (sexp_exceptionp(tmp)) { + res = tmp; + break; + } + } + if (! sexp_exceptionp(res)) { + if (tmp == SEXP_RAWDOT) { /* dotted list */ if (res == SEXP_NULL) { - return sexp_read_error(ctx, "dot before any elements in list", - SEXP_NULL, in); + res = sexp_read_error(ctx, "dot before any elements in list", + SEXP_NULL, in); } else { tmp = sexp_read_raw(ctx, in); - if (sexp_read_raw(ctx, in) != SEXP_CLOSE) { - sexp_deep_free(ctx, res); - return sexp_read_error(ctx, "multiple tokens in dotted tail", - SEXP_NULL, in); + if (sexp_exceptionp(tmp)) { + res = tmp; + } else if (tmp == SEXP_CLOSE) { + res = sexp_read_error(ctx, "no final element in list after dot", + SEXP_NULL, in); + } else if (sexp_read_raw(ctx, in) != SEXP_CLOSE) { + res = sexp_read_error(ctx, "multiple tokens in dotted tail", + SEXP_NULL, in); } else { tmp2 = res; res = sexp_nreverse(ctx, res); sexp_cdr(tmp2) = tmp; - return res; } } + } else if (tmp == SEXP_CLOSE) { + res = (sexp_pairp(res) ? sexp_nreverse(ctx, res) : res); } else { - res = sexp_cons(ctx, tmp, res); - tmp = sexp_read_raw(ctx, in); + res = sexp_read_error(ctx, "missing trailing ')'", SEXP_NULL, in); } } - if (tmp != SEXP_CLOSE) { - sexp_deep_free(ctx, res); - return sexp_read_error(ctx, "missing trailing ')'", SEXP_NULL, in); - } - res = (sexp_pairp(res) ? sexp_nreverse(ctx, res) : res); break; case '#': switch (c1=sexp_read_char(in)) { @@ -987,8 +996,11 @@ sexp sexp_read_raw (sexp ctx, sexp in) { in); } break; +/* case '=': */ +/* case '0': case '1': case '2': case '3': case '4': */ +/* case '5': case '6': case '7': case '8': case '9': */ case ';': - sexp_read_raw(ctx, in); + sexp_read_raw(ctx, in); /* discard */ goto scan_loop; case '\\': c1 = sexp_read_char(in); @@ -1061,8 +1073,7 @@ sexp sexp_read_raw (sexp ctx, sexp in) { if (c2 == '.' || isdigit(c2)) { sexp_push_char(c2, in); res = sexp_read_number(ctx, in, 10); - if (sexp_exceptionp(res)) return res; - if (c1 == '-') { + if ((c1 == '-') && ! sexp_exceptionp(res)) { #ifdef USE_FLONUMS if (sexp_flonump(res)) sexp_flonum_value(res) = -1 * sexp_flonum_value(res); @@ -1084,6 +1095,9 @@ sexp sexp_read_raw (sexp ctx, sexp in) { res = sexp_read_symbol(ctx, in, c1, 1); break; } + + sexp_gc_release(ctx, res, s_res); + sexp_gc_release(ctx, tmp, s_tmp); return res; } diff --git a/sexp.h b/sexp.h index 48603c85..6cd61648 100644 --- a/sexp.h +++ b/sexp.h @@ -179,7 +179,7 @@ struct sexp_struct { /* compiler state */ struct { sexp bc, lambda, *stack, env, fv, parent; - struct sexp_gc_var_t saves; + struct sexp_gc_var_t *saves; sexp_uint_t pos, top, depth, tailp, tracep; } context; } value; @@ -188,6 +188,7 @@ struct sexp_struct { #if USE_BOEHM #define sexp_gc_var(ctx, x, y) sexp x; +#define sexp_gc_preserve(ctx, x, y) #define sexp_gc_release(ctx, x, y) #include "gc/include/gc.h" @@ -200,11 +201,28 @@ struct sexp_struct { #else #define sexp_gc_var(ctx, x, y) \ - sexp x = SEXP_FALSE; \ - struct sexp_gc_var_t y = {&x, &(sexp_context_saves(cxt))}; \ - sexp_context_saves(cxt) = &y; + sexp x = SEXP_FALSE; \ + struct sexp_gc_var_t y; -#define sexp_gc_release(ctx, x, y) (sexp_context_saves(cxt) = y.next) +#define sexp_gc_preserve(ctx, x, y) ((y).var=&(x), \ + (y).next = sexp_context_saves(ctx), \ + sexp_context_saves(ctx) = &(y)) +#define sexp_gc_release(ctx, x, y) (sexp_context_saves(ctx) = y.next) + +#define sexp_with_gc_var1(ctx, x, body) \ + sexp_gc_var(ctx, x, _sexp_gcv1); \ + sexp_gc_preserve(ctx, x, _sexp_gcv1); \ + do {body} while (0); \ + sexp_gc_release(ctx, x, _sexp_gcv1); + +#define sexp_with_gc_var2(ctx, x, y, body) \ + sexp_gc_var(ctx, x, _sexp_gcv1); \ + sexp_gc_var(ctx, y, _sexp_gcv2); \ + sexp_gc_preserve(ctx, x, _sexp_gcv1); \ + sexp_gc_preserve(ctx, y, _sexp_gcv2); \ + do {body} while (0); \ + sexp_gc_release(ctx, x, _sexp_gcv1); \ + sexp_gc_release(ctx, y, _sexp_gcv2); #if USE_MALLOC #define sexp_alloc(ctx, size) malloc(size) @@ -237,11 +255,10 @@ void *sexp_realloc(sexp ctx, sexp x, size_t size); #define SEXP_FALSE SEXP_MAKE_IMMEDIATE(1) #define SEXP_TRUE SEXP_MAKE_IMMEDIATE(2) #define SEXP_EOF SEXP_MAKE_IMMEDIATE(3) -#define SEXP_VOID SEXP_MAKE_IMMEDIATE(4) -#define SEXP_ERROR SEXP_MAKE_IMMEDIATE(5) /* internal use */ -#define SEXP_UNDEF SEXP_MAKE_IMMEDIATE(6) /* internal use */ -#define SEXP_CLOSE SEXP_MAKE_IMMEDIATE(7) /* internal use */ -#define SEXP_RAWDOT SEXP_MAKE_IMMEDIATE(8) /* internal use */ +#define SEXP_VOID SEXP_MAKE_IMMEDIATE(4) /* the unspecified value */ +#define SEXP_UNDEF SEXP_MAKE_IMMEDIATE(5) /* internal use */ +#define SEXP_CLOSE SEXP_MAKE_IMMEDIATE(6) /* internal use */ +#define SEXP_RAWDOT SEXP_MAKE_IMMEDIATE(7) /* internal use */ /***************************** predicates *****************************/ @@ -280,6 +297,9 @@ void *sexp_realloc(sexp ctx, sexp x, size_t size); #define sexp_litp(x) (sexp_check_tag(x, SEXP_LIT)) #define sexp_symbolp(x) (sexp_isymbolp(x) || sexp_lsymbolp(x)) +#define sexp_idp(x) \ + (sexp_symbolp(x) || (sexp_synclop(x) && sexp_symbolp(sexp_synclo_expr(x)))) + /***************************** constructors ****************************/ #define sexp_make_boolean(x) ((x) ? SEXP_TRUE : SEXP_FALSE) @@ -446,7 +466,7 @@ void *sexp_realloc(sexp ctx, sexp x, size_t size); #define sexp_cdadr(x) (sexp_cdr(sexp_cadr(x))) #define sexp_cddar(x) (sexp_cdr(sexp_cdar(x))) #define sexp_cdddr(x) (sexp_cdr(sexp_cddr(x))) -#define sexp_cadddr(x) (sexp_cadr(sexp_cddr(x))) +#define sexp_cadddr(x) (sexp_cadr(sexp_cddr(x))) /* just these two */ #define sexp_cddddr(x) (sexp_cddr(sexp_cddr(x))) /***************************** general API ****************************/ From 0ebdc170cfea7d27332b83c7c557c3f6fc2d7e7d Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 9 May 2009 02:07:52 +0900 Subject: [PATCH 110/154] complifying make_opcode_procedure --- eval.c | 245 +++++++++++++++++++++++++++++++++++++++++---------------- 1 file changed, 178 insertions(+), 67 deletions(-) diff --git a/eval.c b/eval.c index 5e0d5d9e..16be104e 100644 --- a/eval.c +++ b/eval.c @@ -65,10 +65,15 @@ static sexp env_global_ref(sexp e, sexp key, sexp dflt) { static void env_define(sexp ctx, sexp e, sexp key, sexp value) { sexp cell = sexp_assq(ctx, key, sexp_env_bindings(e)); + sexp_gc_var(ctx, tmp, s_tmp); + sexp_gc_preserve(ctx, tmp, s_tmp); if (cell != SEXP_FALSE) sexp_cdr(cell) = value; - else - sexp_push(ctx, sexp_env_bindings(e), sexp_cons(ctx, key, value)); + else { + tmp = sexp_cons(ctx, key, value); + sexp_push(ctx, sexp_env_bindings(e), tmp); + } + sexp_gc_release(ctx, tmp, s_tmp); } static sexp extend_env (sexp ctx, sexp env, sexp vars, sexp value) { @@ -334,10 +339,16 @@ static sexp sexp_identifier_eq(sexp ctx, sexp e1, sexp id1, sexp e2, sexp id2) { /************************* the compiler ***************************/ static sexp sexp_compile_error(sexp ctx, char *message, sexp obj) { - return sexp_make_exception(ctx, the_compile_error_symbol, - sexp_c_string(ctx, message, -1), - sexp_list1(ctx, obj), - SEXP_FALSE, SEXP_FALSE, SEXP_FALSE); + sexp exn; + sexp_gc_var(ctx, irritants, s_irr); + sexp_gc_preserve(ctx, irritants, s_irr); + irritants = sexp_list1(ctx, obj); + exn = sexp_make_exception(ctx, the_compile_error_symbol, + sexp_c_string(ctx, message, -1), + irritants, + SEXP_FALSE, SEXP_FALSE, SEXP_FALSE); + sexp_gc_release(ctx, irritants, s_irr); + return exn; } #define analyze_check_exception(x) do {if (sexp_exceptionp(x)) \ @@ -428,7 +439,17 @@ static sexp analyze_set (sexp ctx, sexp x) { } static sexp analyze_lambda (sexp ctx, sexp x) { - sexp res, body, ls, tmp, name, value, defs=SEXP_NULL; + sexp name, ls; + sexp_gc_var(ctx, res, s_res); + sexp_gc_var(ctx, body, s_body); + sexp_gc_var(ctx, tmp, s_tmp); + sexp_gc_var(ctx, value, s_value); + sexp_gc_var(ctx, defs, s_defs); + sexp_gc_preserve(ctx, res, s_res); + sexp_gc_preserve(ctx, body, s_body); + sexp_gc_preserve(ctx, tmp, s_tmp); + sexp_gc_preserve(ctx, value, s_value); + sexp_gc_preserve(ctx, defs, s_defs); /* verify syntax */ if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) return sexp_compile_error(ctx, "bad lambda syntax", x); @@ -475,24 +496,45 @@ static sexp analyze_lambda (sexp ctx, sexp x) { sexp_seq_ls(body) = sexp_append2(ctx, defs, sexp_seq_ls(body)); } sexp_lambda_body(res) = body; + sexp_gc_release(ctx, res, s_res); + sexp_gc_release(ctx, body, s_body); + sexp_gc_release(ctx, tmp, s_tmp); + sexp_gc_release(ctx, value, s_value); + sexp_gc_release(ctx, defs, s_defs); return res; } static sexp analyze_if (sexp ctx, sexp x) { - sexp test, pass, fail, fail_expr; + sexp res, fail_expr; + sexp_gc_var(ctx, test, s_test); + sexp_gc_var(ctx, pass, s_pass); + sexp_gc_var(ctx, fail, s_fail); + sexp_gc_preserve(ctx, test, s_test); + sexp_gc_preserve(ctx, pass, s_pass); + sexp_gc_preserve(ctx, fail, s_fail); analyze_bind(test, sexp_cadr(x), ctx); analyze_bind(pass, sexp_caddr(x), ctx); fail_expr = sexp_pairp(sexp_cdddr(x)) ? sexp_cadddr(x) : SEXP_VOID; analyze_bind(fail, fail_expr, ctx); - return sexp_make_cnd(ctx, test, pass, fail); + res = sexp_make_cnd(ctx, test, pass, fail); + sexp_gc_release(ctx, test, s_test); + sexp_gc_release(ctx, pass, s_pass); + sexp_gc_release(ctx, fail, s_fail); + return res; } static sexp analyze_define (sexp ctx, sexp x) { - sexp ref, name, value, env = sexp_context_env(ctx); + sexp name, res, env = sexp_context_env(ctx); + sexp_gc_var(ctx, ref, s_ref); + sexp_gc_var(ctx, value, s_value); + sexp_gc_var(ctx, tmp, s_tmp); + sexp_gc_preserve(ctx, ref, s_ref); + sexp_gc_preserve(ctx, value, s_value); + sexp_gc_preserve(ctx, tmp, s_tmp); name = (sexp_pairp(sexp_cadr(x)) ? sexp_caadr(x) : sexp_cadr(x)); if (sexp_env_lambda(env) && sexp_lambdap(sexp_env_lambda(env))) { - sexp_push(ctx, sexp_env_bindings(env), - sexp_cons(ctx, name, sexp_context_lambda(ctx))); + tmp = sexp_cons(ctx, name, sexp_context_lambda(ctx)); + sexp_push(ctx, sexp_env_bindings(env), tmp); sexp_push(ctx, sexp_lambda_sv(sexp_env_lambda(env)), name); sexp_push(ctx, sexp_lambda_locals(sexp_env_lambda(env)), name); sexp_push(ctx, sexp_lambda_defs(sexp_env_lambda(env)), x); @@ -500,43 +542,65 @@ static sexp analyze_define (sexp ctx, sexp x) { } else { env_cell_create(ctx, env, name, SEXP_VOID); } - if (sexp_pairp(sexp_cadr(x))) - value = analyze_lambda(ctx, - sexp_cons(ctx, - SEXP_VOID, - sexp_cons(ctx, - sexp_cdadr(x), - sexp_cddr(x)))); - else + if (sexp_pairp(sexp_cadr(x))) { + tmp = sexp_cons(ctx, sexp_cdadr(x), sexp_cddr(x)); + tmp = sexp_cons(ctx, SEXP_VOID, tmp); + value = analyze_lambda(ctx, tmp); + } else value = analyze(ctx, sexp_caddr(x)); - analyze_check_exception(value); ref = analyze_var_ref(ctx, name); - analyze_check_exception(ref); - return sexp_make_set(ctx, ref, value); + if (sexp_exceptionp(ref)) + res = ref; + else if (sexp_exceptionp(value)) + res = value; + else + res = sexp_make_set(ctx, ref, value); + sexp_gc_release(ctx, ref, s_ref); + sexp_gc_release(ctx, value, s_value); + sexp_gc_release(ctx, tmp, s_tmp); + return res; } static sexp analyze_bind_syntax (sexp ls, sexp eval_ctx, sexp bind_ctx) { - sexp proc; + sexp_gc_var(eval_ctx, proc, s_proc); + sexp_gc_var(eval_ctx, mac, s_mac); + sexp_gc_var(eval_ctx, tmp, s_tmp); + sexp_gc_preserve(eval_ctx, proc, s_proc); + sexp_gc_preserve(eval_ctx, mac, s_mac); + sexp_gc_preserve(eval_ctx, tmp, s_tmp); for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) { proc = eval_in_context(eval_ctx, sexp_cadar(ls)); analyze_check_exception(proc); - if (sexp_procedurep(proc)) - sexp_push(eval_ctx, - sexp_env_bindings(sexp_context_env(bind_ctx)), - sexp_cons(eval_ctx, - sexp_caar(ls), - sexp_make_macro(eval_ctx, proc, - sexp_context_env(eval_ctx)))); + if (sexp_procedurep(proc)) { + mac = sexp_make_macro(eval_ctx, proc, sexp_context_env(eval_ctx)); + tmp = sexp_cons(eval_ctx, sexp_caar(ls), mac); + sexp_push(eval_ctx, sexp_env_bindings(sexp_context_env(bind_ctx)), tmp); + } } + sexp_gc_release(eval_ctx, proc, s_proc); + sexp_gc_release(eval_ctx, mac, s_mac); + sexp_gc_release(eval_ctx, tmp, s_tmp); return SEXP_VOID; } static sexp analyze_define_syntax (sexp ctx, sexp x) { - return analyze_bind_syntax(sexp_list1(ctx, sexp_cdr(x)), ctx, ctx); + sexp res; + sexp_gc_var(ctx, tmp, s_tmp); + sexp_gc_preserve(ctx, tmp, s_tmp); + tmp = sexp_list1(ctx, sexp_cdr(x)); + res = analyze_bind_syntax(tmp, ctx, ctx); + sexp_gc_release(ctx, tmp, s_tmp); + return res; } static sexp analyze_let_syntax (sexp ctx, sexp x) { - sexp env, ctx2, tmp; + sexp res; + sexp_gc_var(ctx, env, s_env); + sexp_gc_var(ctx, ctx2, s_ctx2); + sexp_gc_var(ctx, tmp, s_tmp); + sexp_gc_preserve(ctx, env, s_env); + sexp_gc_preserve(ctx, ctx2, s_ctx2); + sexp_gc_preserve(ctx, tmp, s_tmp); env = sexp_alloc_type(ctx, env, SEXP_ENV); sexp_env_parent(env) = sexp_env_parent(sexp_context_env(ctx)); sexp_env_bindings(env) = sexp_env_bindings(sexp_context_env(ctx)); @@ -544,17 +608,32 @@ static sexp analyze_let_syntax (sexp ctx, sexp x) { sexp_context_env(ctx2) = env; tmp = analyze_bind_syntax(sexp_cadr(x), ctx, ctx2); analyze_check_exception(tmp); - return analyze_seq(ctx2, sexp_cddr(x)); + res = analyze_seq(ctx2, sexp_cddr(x)); + sexp_gc_release(ctx, env, s_env); + sexp_gc_release(ctx, ctx2, s_ctx2); + sexp_gc_release(ctx, tmp, s_tmp); + return res; } static sexp analyze_letrec_syntax (sexp ctx, sexp x) { - sexp tmp = analyze_bind_syntax(sexp_cadr(x), ctx, ctx); - analyze_check_exception(tmp); - return (sexp_exceptionp(tmp) ? tmp : analyze_seq(ctx, sexp_cddr(x))); + sexp res; + sexp_gc_var(ctx, tmp, s_tmp); + sexp_gc_preserve(ctx, tmp, s_tmp); + tmp = analyze_bind_syntax(sexp_cadr(x), ctx, ctx); + res = (sexp_exceptionp(tmp) ? tmp : analyze_seq(ctx, sexp_cddr(x))); + sexp_gc_release(ctx, tmp, s_tmp); + return res; } -static sexp analyze (sexp ctx, sexp x) { - sexp op, cell, res; +static sexp analyze (sexp ctx, sexp object) { + sexp op, cell; + sexp_gc_var(ctx, res, s_res); + sexp_gc_var(ctx, tmp, s_tmp); + sexp_gc_var(ctx, x, s_x); + sexp_gc_preserve(ctx, res, s_res); + sexp_gc_preserve(ctx, tmp, s_tmp); + sexp_gc_preserve(ctx, x, s_x); + x = object; loop: if (sexp_pairp(x)) { if (sexp_listp(ctx, x) == SEXP_FALSE) { @@ -592,10 +671,12 @@ static sexp analyze (sexp ctx, sexp x) { } } else if (sexp_macrop(op)) { /* if (in_repl_p) sexp_debug("expand: ", x, ctx); */ + tmp = sexp_cons(ctx, sexp_macro_env(op), SEXP_NULL); + tmp = sexp_cons(ctx, sexp_context_env(ctx), tmp); + tmp = sexp_cons(ctx, x, tmp); x = apply(sexp_make_child_context(ctx, sexp_context_lambda(ctx)), sexp_macro_proc(op), - sexp_list3(ctx, x, sexp_context_env(ctx), - sexp_macro_env(op))); + tmp); /* if (in_repl_p) sexp_debug(" => ", x, ctx); */ goto loop; } else if (sexp_opcodep(op)) { @@ -629,6 +710,9 @@ static sexp analyze (sexp ctx, sexp x) { } else { res = x; } + sexp_gc_release(ctx, res, s_res); + sexp_gc_release(ctx, tmp, s_tmp); + sexp_gc_release(ctx, x, s_x); return res; } @@ -1006,35 +1090,44 @@ static sexp free_vars (sexp ctx, sexp x, sexp fv) { } static sexp make_param_list(sexp ctx, sexp_uint_t i) { - sexp res = SEXP_NULL; - char sym[2]="a"; - for (sym[0]+=i; i>0; i--) { - sym[0] = sym[0]-1; - res = sexp_cons(ctx, sexp_intern(ctx, sym), res); - } + sexp_gc_var(ctx, res, s_res); + sexp_gc_preserve(ctx, res, s_res); + res = SEXP_NULL; + for ( ; i>0; i--) + res = sexp_cons(ctx, sexp_make_integer(i), res); + sexp_gc_release(ctx, res, s_res); return res; } -static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i, sexp env, - sexp *stack, sexp_sint_t top) { - sexp context, lambda, params, refs, ls, bc, res; +static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i) { + sexp ctx2, lambda, ls, bc, res, env; + sexp_gc_var(ctx, params, s_params); + sexp_gc_var(ctx, ref, s_ref); + sexp_gc_var(ctx, refs, s_refs); + sexp_gc_preserve(ctx, params, s_params); + sexp_gc_preserve(ctx, ref, s_ref); + sexp_gc_preserve(ctx, refs, s_refs); if (i == sexp_opcode_num_args(op) && sexp_opcode_proc(op)) return sexp_opcode_proc(op); params = make_param_list(ctx, i); lambda = sexp_make_lambda(ctx, params); - env = extend_env(ctx, env, params, lambda); - context = sexp_make_context(ctx, stack, env); - sexp_context_lambda(context) = lambda; - sexp_context_top(context) = top; - for (ls=params, refs=SEXP_NULL; sexp_pairp(ls); ls=sexp_cdr(ls)) - sexp_push(context, refs, sexp_make_ref(context, sexp_car(ls), env_cell(env, sexp_car(ls)))); - generate_opcode_app(context, sexp_cons(context, op, sexp_reverse(context, refs))); - bc = finalize_bytecode(context); - sexp_bytecode_name(bc) = sexp_c_string(ctx, sexp_opcode_name(op), -1); - res = sexp_make_procedure(ctx, sexp_make_integer(0), sexp_make_integer(i), + ctx2 = sexp_make_child_context(ctx, lambda); + env = extend_env(ctx2, sexp_context_env(ctx), params, lambda); + sexp_context_env(ctx2) = env; + for (ls=params, refs=SEXP_NULL; sexp_pairp(ls); ls=sexp_cdr(ls)) { + ref = sexp_make_ref(ctx2, sexp_car(ls), env_cell(env, sexp_car(ls))); + sexp_push(ctx2, refs, ref); + } + generate_opcode_app(ctx2, sexp_cons(ctx2, op, sexp_reverse(ctx2, refs))); + bc = finalize_bytecode(ctx2); + sexp_bytecode_name(bc) = sexp_c_string(ctx2, sexp_opcode_name(op), -1); + res = sexp_make_procedure(ctx2, sexp_make_integer(0), sexp_make_integer(i), bc, SEXP_VOID); if (i == sexp_opcode_num_args(op)) sexp_opcode_proc(op) = res; + sexp_gc_release(ctx, params, s_params); + sexp_gc_release(ctx, ref, s_ref); + sexp_gc_release(ctx, refs, s_refs); return res; } @@ -1170,7 +1263,8 @@ sexp vm (sexp self, sexp context, sexp* stack, sexp_sint_t top) { make_call: if (sexp_opcodep(tmp1)) { /* compile non-inlined opcode applications on the fly */ - tmp1 = make_opcode_procedure(context, tmp1, i, env, stack, top); + sexp_context_top(context) = top; + tmp1 = make_opcode_procedure(context, tmp1, i); if (sexp_exceptionp(tmp1)) { _ARG1 = tmp1; goto call_error_handler; @@ -1665,7 +1759,14 @@ static void sexp_warn_undefs (sexp from, sexp to, sexp out) { } sexp sexp_load (sexp ctx, sexp source, sexp env) { - sexp x, res, in, tmp, out, ctx2 = sexp_make_context(ctx, NULL, env); + sexp tmp, out, res=SEXP_VOID; + sexp_gc_var(ctx, ctx2, s_ctx2); + sexp_gc_var(ctx, x, s_x); + sexp_gc_var(ctx, in, s_in); + sexp_gc_preserve(ctx, ctx2, s_ctx2); + sexp_gc_preserve(ctx, x, s_x); + sexp_gc_preserve(ctx, in, s_in); + ctx2 = sexp_make_context(ctx, NULL, env); out = env_global_ref(env, the_cur_err_symbol, SEXP_FALSE); tmp = sexp_env_bindings(env); sexp_context_tailp(ctx2) = 0; @@ -1686,6 +1787,9 @@ sexp sexp_load (sexp ctx, sexp source, sexp env) { if (sexp_oportp(out)) sexp_warn_undefs(sexp_env_bindings(env), tmp, out); #endif + sexp_gc_release(ctx, ctx2, s_ctx2); + sexp_gc_release(ctx, x, s_x); + sexp_gc_release(ctx, in, s_in); return res; } @@ -1862,15 +1966,22 @@ sexp apply(sexp ctx, sexp proc, sexp args) { } sexp compile (sexp ctx, sexp x) { - sexp ast, ctx2; + sexp res; + sexp_gc_var(ctx, ast, s_ast); + sexp_gc_var(ctx, ctx2, s_ctx2); + sexp_gc_preserve(ctx, ast, s_ast); + sexp_gc_preserve(ctx, ctx2, s_ctx2); analyze_bind(ast, x, ctx); free_vars(ctx, ast, SEXP_NULL); /* should return SEXP_NULL */ ctx2 = sexp_make_context(ctx, sexp_context_stack(ctx), sexp_context_env(ctx)); generate(ctx2, ast); - return sexp_make_procedure(ctx, sexp_make_integer(0), - sexp_make_integer(0), - finalize_bytecode(ctx2), - sexp_make_vector(ctx, 0, SEXP_VOID)); + res = sexp_make_procedure(ctx, sexp_make_integer(0), + sexp_make_integer(0), + finalize_bytecode(ctx2), + sexp_make_vector(ctx, 0, SEXP_VOID)); + sexp_gc_release(ctx, ast, s_ast); + sexp_gc_release(ctx, ctx2, s_ctx2); + return res; } sexp eval_in_context (sexp ctx, sexp obj) { From 378cdff8e34180d11929dcad809db8142a33464e Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 9 May 2009 02:34:51 +0900 Subject: [PATCH 111/154] preserving gc vars in generate_lambda --- eval.c | 37 +++++++++++++++---------------------- 1 file changed, 15 insertions(+), 22 deletions(-) diff --git a/eval.c b/eval.c index 16be104e..0a18859d 100644 --- a/eval.c +++ b/eval.c @@ -944,14 +944,14 @@ static void generate_app (sexp ctx, sexp app) { } static void generate_lambda (sexp ctx, sexp lambda) { - sexp fv, ls, ctx2, flags, bc, len, ref, vec, prev_lambda, prev_fv; + sexp ctx2, fv, ls, flags, bc, len, ref, prev_lambda, prev_fv; sexp_uint_t k; + sexp_gc_var(ctx, vec, s_vec); + sexp_gc_preserve(ctx, vec, s_vec); prev_lambda = sexp_context_lambda(ctx); prev_fv = sexp_lambdap(prev_lambda) ? sexp_lambda_fv(prev_lambda) : SEXP_NULL; fv = sexp_lambda_fv(lambda); - ctx2 = sexp_make_context(ctx, - sexp_context_stack(ctx), - sexp_context_env(ctx)); + ctx2 = sexp_make_context(ctx, sexp_context_stack(ctx), sexp_context_env(ctx)); sexp_context_lambda(ctx2) = lambda; /* allocate space for local vars */ for (ls=sexp_lambda_locals(lambda); sexp_pairp(ls); ls=sexp_cdr(ls)) @@ -978,8 +978,8 @@ static void generate_lambda (sexp ctx, sexp lambda) { sexp_bytecode_name(bc) = sexp_lambda_name(lambda); if (sexp_nullp(fv)) { /* shortcut, no free vars */ - vec = sexp_make_vector(ctx, sexp_make_integer(0), SEXP_VOID); - generate_lit(ctx, sexp_make_procedure(ctx, flags, len, bc, vec)); + vec = sexp_make_vector(ctx2, sexp_make_integer(0), SEXP_VOID); + generate_lit(ctx, sexp_make_procedure(ctx2, flags, len, bc, vec)); } else { /* push the closed vars */ emit_push(ctx, SEXP_VOID); @@ -1003,27 +1003,20 @@ static void generate_lambda (sexp ctx, sexp lambda) { emit_push(ctx, flags); emit(ctx, OP_MAKE_PROCEDURE); } + sexp_gc_release(ctx, vec, s_vec); } static void generate (sexp ctx, sexp x) { if (sexp_pointerp(x)) { switch (sexp_pointer_tag(x)) { - case SEXP_PAIR: - generate_app(ctx, x); break; - case SEXP_LAMBDA: - generate_lambda(ctx, x); break; - case SEXP_CND: - generate_cnd(ctx, x); break; - case SEXP_REF: - generate_ref(ctx, x, 1); break; - case SEXP_SET: - generate_set(ctx, x); break; - case SEXP_SEQ: - generate_seq(ctx, sexp_seq_ls(x)); break; - case SEXP_LIT: - generate_lit(ctx, sexp_lit_value(x)); break; - default: - generate_lit(ctx, x); + case SEXP_PAIR: generate_app(ctx, x); break; + case SEXP_LAMBDA: generate_lambda(ctx, x); break; + case SEXP_CND: generate_cnd(ctx, x); break; + case SEXP_REF: generate_ref(ctx, x, 1); break; + case SEXP_SET: generate_set(ctx, x); break; + case SEXP_SEQ: generate_seq(ctx, sexp_seq_ls(x)); break; + case SEXP_LIT: generate_lit(ctx, sexp_lit_value(x)); break; + default: generate_lit(ctx, x); } } else { generate_lit(ctx, x); From d65e7255f86e6de05f2af2014b50565d51d134e1 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 8 Jun 2009 02:06:24 +0900 Subject: [PATCH 112/154] stack is now a data type (maybe merge w/ vector), new gc seems initially functional --- Makefile | 4 +- eval.c | 221 ++++++++++++++++++++-------------------- gc.c | 299 +++++++++++++++++++++++++++++++++++++++++++++++++------ sexp.c | 26 +++-- sexp.h | 47 +++++---- 5 files changed, 432 insertions(+), 165 deletions(-) diff --git a/Makefile b/Makefile index fe8e381a..6dc9b848 100644 --- a/Makefile +++ b/Makefile @@ -12,7 +12,7 @@ MODDIR=$(PREFIX)/share/chibi-scheme LDFLAGS=-lm # -Oz for smaller size on darwin -CFLAGS=-Wall -g -Os -save-temps +CFLAGS=-Wall -g -save-temps #GC_OBJ=./gc/gc.a GC_OBJ= @@ -20,7 +20,7 @@ GC_OBJ= ./gc/gc.a: ./gc/alloc.c cd gc && make -sexp.o: sexp.c sexp.h config.h defaults.h Makefile +sexp.o: sexp.c gc.c sexp.h config.h defaults.h Makefile gcc -c $(CPPFLAGS) $(CFLAGS) -o $@ $< eval.o: eval.c debug.c opcodes.c eval.h sexp.h config.h defaults.h Makefile diff --git a/eval.c b/eval.c index 0a18859d..ba4aa3d8 100644 --- a/eval.c +++ b/eval.c @@ -8,7 +8,7 @@ static int scheme_initialized_p = 0; -static sexp continuation_resumer, final_resumer; +sexp continuation_resumer, final_resumer; static sexp the_interaction_env_symbol; static sexp the_err_handler_symbol, the_compile_error_symbol; static sexp the_cur_in_symbol, the_cur_out_symbol, the_cur_err_symbol; @@ -89,7 +89,6 @@ static sexp extend_env (sexp ctx, sexp env, sexp vars, sexp value) { sexp_push(ctx, sexp_env_bindings(e), tmp); } sexp_gc_release(ctx, e, s_e); - sexp_gc_release(ctx, tmp, s_tmp); return e; } @@ -247,12 +246,16 @@ static sexp sexp_make_lit(sexp ctx, sexp value) { return res; } -static sexp sexp_make_context(sexp ctx, sexp *stack, sexp env) { +static sexp sexp_make_context(sexp ctx, sexp stack, sexp env) { sexp_gc_var(ctx, res, save_res); if (ctx) sexp_gc_preserve(ctx, res, save_res); res = sexp_alloc_type(ctx, context, SEXP_CONTEXT); - sexp_context_stack(res) - = (stack ? stack : (sexp*) sexp_alloc(res, sizeof(sexp)*INIT_STACK_SIZE)); + if ((! stack) || (stack == SEXP_FALSE)) { + stack = sexp_alloc_tagged(ctx, sizeof(sexp)*INIT_STACK_SIZE, SEXP_STACK); + sexp_stack_length(stack) = INIT_STACK_SIZE; + sexp_stack_top(stack) = 0; + } + sexp_context_stack(res) = stack; sexp_context_env(res) = (env ? env : sexp_make_standard_env(res, sexp_make_integer(5))); sexp_context_bc(res) @@ -313,7 +316,6 @@ static sexp sexp_strip_synclos (sexp ctx, sexp x) { res = x; } sexp_gc_release(ctx, kar, s_kar); - sexp_gc_release(ctx, kdr, s_kdr); return res; } @@ -434,7 +436,6 @@ static sexp analyze_set (sexp ctx, sexp x) { else res = sexp_make_set(ctx, ref, value); sexp_gc_release(ctx, ref, s_ref); - sexp_gc_release(ctx, value, s_value); return res; } @@ -497,10 +498,6 @@ static sexp analyze_lambda (sexp ctx, sexp x) { } sexp_lambda_body(res) = body; sexp_gc_release(ctx, res, s_res); - sexp_gc_release(ctx, body, s_body); - sexp_gc_release(ctx, tmp, s_tmp); - sexp_gc_release(ctx, value, s_value); - sexp_gc_release(ctx, defs, s_defs); return res; } @@ -518,8 +515,6 @@ static sexp analyze_if (sexp ctx, sexp x) { analyze_bind(fail, fail_expr, ctx); res = sexp_make_cnd(ctx, test, pass, fail); sexp_gc_release(ctx, test, s_test); - sexp_gc_release(ctx, pass, s_pass); - sexp_gc_release(ctx, fail, s_fail); return res; } @@ -556,8 +551,6 @@ static sexp analyze_define (sexp ctx, sexp x) { else res = sexp_make_set(ctx, ref, value); sexp_gc_release(ctx, ref, s_ref); - sexp_gc_release(ctx, value, s_value); - sexp_gc_release(ctx, tmp, s_tmp); return res; } @@ -578,8 +571,6 @@ static sexp analyze_bind_syntax (sexp ls, sexp eval_ctx, sexp bind_ctx) { } } sexp_gc_release(eval_ctx, proc, s_proc); - sexp_gc_release(eval_ctx, mac, s_mac); - sexp_gc_release(eval_ctx, tmp, s_tmp); return SEXP_VOID; } @@ -610,8 +601,6 @@ static sexp analyze_let_syntax (sexp ctx, sexp x) { analyze_check_exception(tmp); res = analyze_seq(ctx2, sexp_cddr(x)); sexp_gc_release(ctx, env, s_env); - sexp_gc_release(ctx, ctx2, s_ctx2); - sexp_gc_release(ctx, tmp, s_tmp); return res; } @@ -711,8 +700,6 @@ static sexp analyze (sexp ctx, sexp object) { res = x; } sexp_gc_release(ctx, res, s_res); - sexp_gc_release(ctx, tmp, s_tmp); - sexp_gc_release(ctx, x, s_x); return res; } @@ -1119,8 +1106,6 @@ static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i) { if (i == sexp_opcode_num_args(op)) sexp_opcode_proc(op) = res; sexp_gc_release(ctx, params, s_params); - sexp_gc_release(ctx, ref, s_ref); - sexp_gc_release(ctx, refs, s_refs); return res; } @@ -1155,24 +1140,36 @@ static sexp_uint_t sexp_restore_stack(sexp saved, sexp *current) { #define _UWORD0 ((sexp_uint_t*)ip)[0] #define _SWORD0 ((sexp_sint_t*)ip)[0] -#define sexp_raise(msg, args) do {stack[top]=sexp_user_exception(context, self, msg, args); \ - top++; \ - goto call_error_handler;} \ - while (0) +#define sexp_raise(msg, args) \ + do {sexp_context_top(ctx) = top+1; \ + stack[top] = args; \ + stack[top] = sexp_user_exception(ctx, self, msg, stack[top]); \ + top++; \ + goto call_error_handler;} \ + while (0) #define sexp_check_exception() do {if (sexp_exceptionp(_ARG1)) \ goto call_error_handler;} \ while (0) -sexp vm (sexp self, sexp context, sexp* stack, sexp_sint_t top) { - sexp bc = sexp_procedure_code(self), cp = sexp_procedure_vars(self); - unsigned char *ip=sexp_bytecode_data(bc); - sexp tmp1, tmp2, env=sexp_context_env(context); - sexp_sint_t i, j, k, fp=top-4; +sexp vm (sexp proc, sexp ctx) { + sexp bc = sexp_procedure_code(proc), cp = sexp_procedure_vars(proc); + sexp env = sexp_context_env(ctx), + *stack = sexp_stack_data(sexp_context_stack(ctx)); + unsigned char *ip = sexp_bytecode_data(bc); + sexp_sint_t i, j, k, fp, top = sexp_stack_top(sexp_context_stack(ctx)); + fp = top - 4; + sexp_gc_var(ctx, self, s_self); + sexp_gc_var(ctx, tmp1, s_tmp1); + sexp_gc_var(ctx, tmp2, s_tmp2); + sexp_gc_preserve(ctx, self, s_self); + sexp_gc_preserve(ctx, tmp1, s_tmp1); + sexp_gc_preserve(ctx, tmp2, s_tmp2); + self = proc; loop: #ifdef DEBUG_VM - if (sexp_context_tracep(context)) { + if (sexp_context_tracep(ctx)) { sexp_print_stack(stack, top, fp, env_global_ref(env, the_cur_err_symbol, SEXP_FALSE)); fprintf(stderr, "%s\n", (*ip<=71)?reverse_opcode_names[*ip]:"UNKNOWN"); @@ -1213,8 +1210,9 @@ sexp vm (sexp self, sexp context, sexp* stack, sexp_sint_t top) { stack[top+3] = sexp_make_integer(fp); tmp1 = _ARG1; i = 1; - tmp2 = sexp_vector(context, 1, sexp_save_stack(context, stack, top+4)); - _ARG1 = sexp_make_procedure(context, sexp_make_integer(0), + sexp_context_top(ctx) = top; + tmp2 = sexp_vector(ctx, 1, sexp_save_stack(ctx, stack, top+4)); + _ARG1 = sexp_make_procedure(ctx, sexp_make_integer(0), sexp_make_integer(1), continuation_resumer, tmp2); top++; @@ -1223,7 +1221,7 @@ sexp vm (sexp self, sexp context, sexp* stack, sexp_sint_t top) { case OP_APPLY1: tmp1 = _ARG1; tmp2 = _ARG2; - i = sexp_unbox_integer(sexp_length(context, tmp2)); + i = sexp_unbox_integer(sexp_length(ctx, tmp2)); top += (i-2); for ( ; sexp_pairp(tmp2); tmp2=sexp_cdr(tmp2), top--) _ARG1 = sexp_car(tmp2); @@ -1256,29 +1254,31 @@ sexp vm (sexp self, sexp context, sexp* stack, sexp_sint_t top) { make_call: if (sexp_opcodep(tmp1)) { /* compile non-inlined opcode applications on the fly */ - sexp_context_top(context) = top; - tmp1 = make_opcode_procedure(context, tmp1, i); + sexp_context_top(ctx) = top; + tmp1 = make_opcode_procedure(ctx, tmp1, i); if (sexp_exceptionp(tmp1)) { _ARG1 = tmp1; goto call_error_handler; } } if (! sexp_procedurep(tmp1)) - sexp_raise("non procedure application", sexp_list1(context, tmp1)); + sexp_raise("non procedure application", sexp_list1(ctx, tmp1)); j = i - sexp_unbox_integer(sexp_procedure_num_args(tmp1)); if (j < 0) - sexp_raise("not enough args", sexp_list2(context, tmp1, sexp_make_integer(i))); + sexp_raise("not enough args", + sexp_list2(ctx, tmp1, sexp_make_integer(i))); if (j > 0) { if (sexp_procedure_variadic_p(tmp1)) { - stack[top-i-1] = sexp_cons(context, stack[top-i-1], SEXP_NULL); + stack[top-i-1] = sexp_cons(ctx, stack[top-i-1], SEXP_NULL); for (k=top-i; kinexact: not a number", sexp_list1(context, _ARG1)); + sexp_raise("exact->inexact: not a number", sexp_list1(ctx, _ARG1)); break; case OP_FLO2FIX: #if USE_FLONUMS @@ -1629,7 +1632,7 @@ sexp vm (sexp self, sexp context, sexp* stack, sexp_sint_t top) { else #endif if (! sexp_integerp(_ARG1)) - sexp_raise("inexact->exact: not a number", sexp_list1(context, _ARG1)); + sexp_raise("inexact->exact: not a number", sexp_list1(ctx, _ARG1)); break; case OP_CHAR2INT: _ARG1 = sexp_make_integer(sexp_unbox_character(_ARG1)); @@ -1675,7 +1678,7 @@ sexp vm (sexp self, sexp context, sexp* stack, sexp_sint_t top) { _ARG1 = SEXP_VOID; break; case OP_READ: - _ARG1 = sexp_read(context, _ARG1); + _ARG1 = sexp_read(ctx, _ARG1); sexp_check_exception(); break; case OP_READ_CHAR: @@ -1700,11 +1703,12 @@ sexp vm (sexp self, sexp context, sexp* stack, sexp_sint_t top) { case OP_DONE: goto end_loop; default: - sexp_raise("unknown opcode", sexp_list1(context, sexp_make_integer(*(ip-1)))); + sexp_raise("unknown opcode", sexp_list1(ctx, sexp_make_integer(*(ip-1)))); } goto loop; end_loop: + sexp_gc_release(ctx, self, s_self); return _ARG1; } @@ -1719,10 +1723,12 @@ static sexp sexp_exception_type_func (sexp ctx, sexp exn) { static sexp sexp_open_input_file (sexp ctx, sexp path) { FILE *in; - if (! sexp_stringp(path)) return sexp_type_exception(ctx, "not a string", path); + if (! sexp_stringp(path)) + return sexp_type_exception(ctx, "not a string", path); in = fopen(sexp_string_data(path), "r"); if (! in) - return sexp_user_exception(ctx, SEXP_FALSE, "couldn't open input file", path); + return + sexp_user_exception(ctx, SEXP_FALSE, "couldn't open input file", path); return sexp_make_input_port(ctx, in, sexp_string_data(path)); } @@ -1732,7 +1738,8 @@ static sexp sexp_open_output_file (sexp ctx, sexp path) { return sexp_type_exception(ctx, "not a string", path); out = fopen(sexp_string_data(path), "w"); if (! out) - return sexp_user_exception(ctx, SEXP_FALSE, "couldn't open output file", path); + return + sexp_user_exception(ctx, SEXP_FALSE, "couldn't open output file", path); return sexp_make_input_port(ctx, out, sexp_string_data(path)); } @@ -1781,8 +1788,6 @@ sexp sexp_load (sexp ctx, sexp source, sexp env) { sexp_warn_undefs(sexp_env_bindings(env), tmp, out); #endif sexp_gc_release(ctx, ctx2, s_ctx2); - sexp_gc_release(ctx, x, s_x); - sexp_gc_release(ctx, in, s_in); return res; } @@ -1796,8 +1801,8 @@ sexp sexp_load (sexp ctx, sexp source, sexp env) { else if (sexp_integerp(z)) \ d = (double)sexp_unbox_integer(z); \ else \ - return sexp_type_exception(ctx, "not a number", z); \ - return sexp_make_flonum(ctx, cname(d)); \ + return sexp_type_exception(ctx, "not a number", z); \ + return sexp_make_flonum(ctx, cname(d)); \ } define_math_op(sexp_exp, exp) @@ -1898,6 +1903,7 @@ static struct sexp_struct core_forms[] = { static sexp sexp_make_null_env (sexp ctx, sexp version) { sexp_uint_t i; sexp e = sexp_alloc_type(ctx, env, SEXP_ENV); + sexp_env_lambda(e) = NULL; sexp_env_parent(e) = NULL; sexp_env_bindings(e) = SEXP_NULL; for (i=0; i<(sizeof(core_forms)/sizeof(core_forms[0])); i++) @@ -1938,14 +1944,13 @@ static sexp sexp_make_standard_env (sexp ctx, sexp version) { sexp_make_output_port(ctx, stderr, NULL)); env_define(ctx, e, the_interaction_env_symbol, e); sexp_gc_release(ctx, e, s_e); - sexp_gc_release(ctx, op, s_op); return e; } /************************** eval interface ****************************/ -sexp apply(sexp ctx, sexp proc, sexp args) { - sexp *stack = sexp_context_stack(ctx), ls; +sexp apply (sexp ctx, sexp proc, sexp args) { + sexp ls, *stack = sexp_stack_data(sexp_context_stack(ctx)); sexp_sint_t top = sexp_context_top(ctx), offset; offset = top + sexp_unbox_integer(sexp_length(ctx, args)); for (ls=args; sexp_pairp(ls); ls=sexp_cdr(ls), top++) @@ -1955,7 +1960,8 @@ sexp apply(sexp ctx, sexp proc, sexp args) { stack[top++] = sexp_make_integer(sexp_bytecode_data(final_resumer)); stack[top++] = sexp_make_vector(ctx, 0, SEXP_VOID); stack[top++] = sexp_make_integer(0); - return vm(proc, ctx, stack, top); + sexp_context_top(ctx) = top; + return vm(proc, ctx); } sexp compile (sexp ctx, sexp x) { @@ -1973,7 +1979,6 @@ sexp compile (sexp ctx, sexp x) { finalize_bytecode(ctx2), sexp_make_vector(ctx, 0, SEXP_VOID)); sexp_gc_release(ctx, ast, s_ast); - sexp_gc_release(ctx, ctx2, s_ctx2); return res; } diff --git a/gc.c b/gc.c index 2d1ecca0..afb57970 100644 --- a/gc.c +++ b/gc.c @@ -4,7 +4,7 @@ #include "sexp.h" -#define SEXP_INITIAL_HEAP_SIZE 100000000 +#define SEXP_INITIAL_HEAP_SIZE 50000 #define SEXP_MINIMUM_OBJECT_SIZE (sexp_sizeof(flonum)) static char* sexp_heap; @@ -18,6 +18,8 @@ sexp_uint_t sexp_allocated_bytes (sexp x) { case SEXP_STRING: return sexp_sizeof(string)+sexp_string_length(x); case SEXP_VECTOR: return sexp_sizeof(vector)+(sexp_vector_length(x)*sizeof(sexp)); + case SEXP_STACK: + return sexp_sizeof(stack)+(sexp_stack_length(x)*sizeof(sexp)); case SEXP_FLONUM: return sexp_sizeof(flonum); case SEXP_BIGNUM: return sexp_sizeof(bignum); case SEXP_IPORT: @@ -37,27 +39,46 @@ sexp_uint_t sexp_allocated_bytes (sexp x) { case SEXP_SEQ: return sexp_sizeof(seq); case SEXP_LIT: return sexp_sizeof(lit); case SEXP_CONTEXT: return sexp_sizeof(context); - default: return 0; + default: return sexp_align(1, 4); } } void sexp_mark (sexp x) { sexp *data; sexp_uint_t i; + struct sexp_gc_var_t *saves; loop: - if ((! sexp_pointerp(x)) || sexp_gc_mark(x)) + if (((char*)x < sexp_heap) || ((char*)x >= sexp_heap_end)) { + if (x && sexp_pointerp(x) && (sexp_pointer_tag(x) != SEXP_OPCODE)) + fprintf(stderr, "--------------- outside heap: %p (%x) ------------------\n", x, sexp_pointer_tag(x)); + return; + } + if ((! x) || (! sexp_pointerp(x)) || sexp_gc_mark(x)) return; sexp_gc_mark(x) = 1; + fprintf(stderr, "----------------- marking %p (%x) --------------------\n", + x, sexp_pointer_tag(x)); switch (sexp_pointer_tag(x)) { case SEXP_PAIR: sexp_mark(sexp_car(x)); x = sexp_cdr(x); goto loop; + case SEXP_STACK: + data = sexp_stack_data(x); + if (! sexp_stack_top(x)) break; + for (i=sexp_stack_top(x)-1; i>0; i--) + sexp_mark(data[i]); + x = data[0]; + goto loop; case SEXP_VECTOR: data = sexp_vector_data(x); + if (! sexp_vector_length(x)) break; for (i=sexp_vector_length(x)-1; i>0; i--) sexp_mark(data[i]); - x = data[i]; + x = data[0]; + goto loop; + case SEXP_SYMBOL: + x = sexp_symbol_string(x); goto loop; case SEXP_BYTECODE: x = sexp_bytecode_literals(x); @@ -119,71 +140,287 @@ void sexp_mark (sexp x) { case SEXP_LIT: x = sexp_lit_value(x); goto loop; + case SEXP_CONTEXT: + sexp_mark(sexp_context_env(x)); + sexp_mark(sexp_context_bc(x)); + sexp_mark(sexp_context_fv(x)); + sexp_mark(sexp_context_lambda(x)); + sexp_mark(sexp_context_parent(x)); + for (saves=sexp_context_saves(x); saves; saves=saves->next) + if (saves->var) sexp_mark(*(saves->var)); + x = sexp_context_stack(x); + goto loop; } } +void simple_write (sexp obj, int depth, FILE *out) { + unsigned long len, c, res; + long i=0; + double f; + char *str=NULL; + + if (! obj) { + fputs("#", out); + } if (! sexp_pointerp(obj)) { + if (sexp_integerp(obj)) { + fprintf(out, "%ld", sexp_unbox_integer(obj)); + } else if (sexp_charp(obj)) { + if (obj == sexp_make_character(' ')) + fputs("#\\space", out); + else if (obj == sexp_make_character('\n')) + fputs("#\\newline", out); + else if (obj == sexp_make_character('\r')) + fputs("#\\return", out); + else if (obj == sexp_make_character('\t')) + fputs("#\\tab", out); + else if ((33 <= sexp_unbox_character(obj)) + && (sexp_unbox_character(obj) < 127)) + fprintf(out, "#\\%c", sexp_unbox_character(obj)); + else + fprintf(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" + putc(res, out); + } + } +#endif + + } else { + switch ((sexp_uint_t) obj) { + case (sexp_uint_t) SEXP_NULL: + fputs("()", out); break; + case (sexp_uint_t) SEXP_TRUE: + fputs("#t", out); break; + case (sexp_uint_t) SEXP_FALSE: + fputs("#f", out); break; + case (sexp_uint_t) SEXP_EOF: + fputs("#", out); break; + case (sexp_uint_t) SEXP_UNDEF: + case (sexp_uint_t) SEXP_VOID: + fputs("#", out); break; + default: + fprintf(out, "#", obj); + } + } + } else if (depth <= 0) { + fprintf(out, "#<...>"); + } else { + switch (sexp_pointer_tag(obj)) { + case SEXP_PAIR: + putc('(', out); + simple_write(sexp_car(obj), depth-1, out); + if (sexp_pairp(sexp_cdr(obj))) { + fputs(" ...", out); + } else if (! sexp_nullp(sexp_cdr(obj))) { + fputs(" . ", out); + simple_write(sexp_cdr(obj), depth-1, out); + } + putc(')', out); + break; + case SEXP_VECTOR: + len = sexp_vector_length(obj); + if (len == 0) { + fputs("#()", out); + } else { + fprintf(out, "#(... %ld ...)", len); + } + break; + case SEXP_FLONUM: + f = sexp_flonum_value(obj); + fprintf(out, "%.15g%s", f, (f == trunc(f)) ? ".0" : ""); + break; + case SEXP_PROCEDURE: + fputs("#', out); + break; + case SEXP_IPORT: + fputs("#", out); break; + case SEXP_OPORT: + fputs("#", out); break; + case SEXP_CORE: + fputs("#", out); break; + case SEXP_OPCODE: + fputs("#", out); break; + case SEXP_BYTECODE: + fputs("#", out); break; + case SEXP_ENV: + fprintf(out, "#", obj); break; + case SEXP_EXCEPTION: + fputs("#", out); break; + case SEXP_MACRO: + fputs("#", out); break; + case SEXP_LAMBDA: + fputs("#', out); + break; + case SEXP_SEQ: + fputs("#', out); + break; + case SEXP_CND: + fputs("#', out); + break; + case SEXP_REF: + fputs("#", sexp_ref_loc(obj)); + break; + case SEXP_SET: + fputs("#', out); + break; + case SEXP_LIT: + fputs("#', out); + break; + case SEXP_CONTEXT: + fputs("#", out); + break; + case SEXP_SYNCLO: + fputs("#', out); + break; + case SEXP_STRING: + putc('"', out); + i = sexp_string_length(obj); + str = sexp_string_data(obj); + for ( ; i>0; str++, i--) { + switch (str[0]) { + case '\\': fputs("\\\\", out); break; + case '"': fputs("\\\"", out); break; + case '\n': fputs("\\n", out); break; + case '\r': fputs("\\r", out); break; + case '\t': fputs("\\t", out); break; + default: putc(str[0], out); + } + } + putc('"', out); + break; + case SEXP_SYMBOL: + i = sexp_string_length(sexp_symbol_string(obj)); + str = sexp_string_data(sexp_symbol_string(obj)); + for ( ; i>0; str++, i--) { + if ((str[0] == '\\') || is_separator(str[0])) + putc('\\', out); + putc(str[0], out); + } + break; + default: + fprintf(out, "#", sexp_pointer_tag(obj)); + break; + } + } +} + +void sexp_show_free_list (sexp ctx) { + sexp p=sexp_free_list; + fputs("free-list:", stderr); + while (p && sexp_pairp(p) && ((char*) p < sexp_heap_end)) { + fprintf(stderr, " %p-%p", p, p+(sexp_uint_t)sexp_car(p)); + p = sexp_cdr(p); + } + putc('\n', stderr); +} + sexp sexp_sweep (sexp ctx) { sexp_uint_t freed=0, size; - sexp p=(sexp)sexp_heap, f1=sexp_free_list, f2; + sexp p=(sexp)(sexp_heap+sexp_align(SEXP_MINIMUM_OBJECT_SIZE, 4)); + sexp f1=sexp_free_list, f2; + /* scan over the whole heap */ while ((char*)pnext) - if (saves->var) sexp_mark(*(saves->var)); - } + sexp_mark(ctx); return sexp_sweep(ctx); } void *sexp_alloc (sexp ctx, size_t size) { + int tries = 0; sexp ls1, ls2, ls3; - size = sexp_align(size, 3); + size = sexp_align(size, 4); try_alloc: - ls1=sexp_free_list; - for (ls2=sexp_cdr(ls1); sexp_pairp(ls2); ls1=ls2, ls2=sexp_cdr(ls2)) + ls1 = sexp_free_list; + ls2 = sexp_cdr(ls1); + for (ls2=sexp_cdr(ls1); sexp_pairp(ls2); ) { if ((sexp_uint_t)sexp_car(ls2) >= size) { - if ((sexp_uint_t)sexp_car(ls2) >= size + SEXP_MINIMUM_OBJECT_SIZE) { - ls3 = (sexp) (((char*)ls2)+size); + if ((sexp_uint_t)sexp_car(ls2) >= (size + SEXP_MINIMUM_OBJECT_SIZE)) { + ls3 = (sexp) (((char*)ls2)+size); /* the free tail after ls2 */ sexp_pointer_tag(ls3) = SEXP_PAIR; sexp_car(ls3) = (sexp) (((sexp_uint_t)sexp_car(ls2)) - size); sexp_cdr(ls3) = sexp_cdr(ls2); sexp_cdr(ls1) = ls3; - } else { + } else { /* take the whole chunk */ sexp_cdr(ls1) = sexp_cdr(ls2); } bzero((void*)ls2, size); return ls2; } - if (sexp_unbox_integer(sexp_gc(ctx)) >= size) { + ls1=ls2; + ls2=sexp_cdr(ls2); + } + if ((! tries) && (sexp_unbox_integer(sexp_gc(ctx)) >= size)) { + tries++; goto try_alloc; } else { - fprintf(stderr, "chibi: out of memory trying to allocate %ld bytes, aborting\n", size); + fprintf(stderr, + "chibi: out of memory trying to allocate %ld bytes, aborting\n", + size); exit(70); } } @@ -193,12 +430,14 @@ void sexp_gc_init () { sexp_heap = malloc(SEXP_INITIAL_HEAP_SIZE); sexp_heap_end = sexp_heap + SEXP_INITIAL_HEAP_SIZE; sexp_free_list = (sexp)sexp_heap; - next = (sexp) (sexp_heap + sexp_sizeof(pair)); + next = (sexp) (sexp_heap + sexp_align(sexp_sizeof(pair), 4)); sexp_pointer_tag(sexp_free_list) = SEXP_PAIR; sexp_car(sexp_free_list) = 0; /* actually sexp_sizeof(pair) */ sexp_cdr(sexp_free_list) = next; sexp_pointer_tag(next) = SEXP_PAIR; - sexp_car(next) = (sexp) (SEXP_INITIAL_HEAP_SIZE-sexp_sizeof(pair)); + sexp_car(next) = (sexp) (SEXP_INITIAL_HEAP_SIZE + - sexp_align(sexp_sizeof(pair), 4)); sexp_cdr(next) = SEXP_NULL; + fprintf(stderr, "heap: %p - %p, next: %p\n", sexp_heap, sexp_heap_end, next); } diff --git a/sexp.c b/sexp.c index 5b39a125..04745ee1 100644 --- a/sexp.c +++ b/sexp.c @@ -117,10 +117,17 @@ sexp sexp_type_exception (sexp ctx, char *message, sexp obj) { } sexp sexp_range_exception (sexp ctx, sexp obj, sexp start, sexp end) { - return sexp_make_exception(ctx, sexp_intern(ctx, "range"), - sexp_c_string(ctx, "bad index range", -1), - sexp_list3(ctx, obj, start, end), - SEXP_FALSE, SEXP_FALSE, SEXP_FALSE); + sexp_gc_var(ctx, res, s_res); + sexp_gc_var(ctx, msg, s_msg); + sexp_gc_preserve(ctx, res, s_res); + sexp_gc_preserve(ctx, msg, s_msg); + msg = sexp_c_string(ctx, "bad index range", -1); + res = sexp_list2(ctx, start, end); + res = sexp_cons(ctx, obj, res); + res = sexp_make_exception(ctx, sexp_intern(ctx, "range"), msg, res, + SEXP_FALSE, SEXP_FALSE, SEXP_FALSE); + sexp_gc_release(ctx, res, s_res); + return res; } sexp sexp_print_exception (sexp ctx, sexp exn, sexp out) { @@ -193,6 +200,15 @@ sexp sexp_cons (sexp ctx, sexp head, sexp tail) { return pair; } +sexp sexp_list2 (sexp ctx, sexp a, sexp b) { + sexp_gc_var(ctx, res, s_res); + sexp_gc_preserve(ctx, res, s_res); + res = sexp_cons(ctx, b, SEXP_NULL); + res = sexp_cons(ctx, a, res); + sexp_gc_release(ctx, res, s_res); + return res; +} + sexp sexp_listp (sexp ctx, sexp hare) { sexp turtle; if (! sexp_pairp(hare)) @@ -996,7 +1012,6 @@ sexp sexp_read_raw (sexp ctx, sexp in) { in); } break; -/* case '=': */ /* case '0': case '1': case '2': case '3': case '4': */ /* case '5': case '6': case '7': case '8': case '9': */ case ';': @@ -1097,7 +1112,6 @@ sexp sexp_read_raw (sexp ctx, sexp in) { } sexp_gc_release(ctx, res, s_res); - sexp_gc_release(ctx, tmp, s_tmp); return res; } diff --git a/sexp.h b/sexp.h index 6cd61648..6d4b8789 100644 --- a/sexp.h +++ b/sexp.h @@ -78,6 +78,7 @@ enum sexp_types { SEXP_SET, SEXP_SEQ, SEXP_LIT, + SEXP_STACK, SEXP_CONTEXT, }; @@ -178,13 +179,29 @@ struct sexp_struct { } lit; /* compiler state */ struct { - sexp bc, lambda, *stack, env, fv, parent; + sexp_uint_t length, top; + sexp data[]; + } stack; + struct { + sexp bc, lambda, stack, env, fv, parent; struct sexp_gc_var_t *saves; - sexp_uint_t pos, top, depth, tailp, tracep; + sexp_uint_t pos, depth, tailp, tracep; } context; } value; }; +#define SEXP_MAKE_IMMEDIATE(n) ((sexp) ((n<value.lit.value) +#define sexp_stack_length(x) ((x)->value.stack.length) +#define sexp_stack_top(x) ((x)->value.stack.top) +#define sexp_stack_data(x) ((x)->value.stack.data) + #define sexp_context_env(x) ((x)->value.context.env) #define sexp_context_stack(x) ((x)->value.context.stack) #define sexp_context_depth(x) ((x)->value.context.depth) #define sexp_context_bc(x) ((x)->value.context.bc) #define sexp_context_fv(x) ((x)->value.context.fv) #define sexp_context_pos(x) ((x)->value.context.pos) -#define sexp_context_top(x) ((x)->value.context.top) #define sexp_context_lambda(x) ((x)->value.context.lambda) #define sexp_context_parent(x) ((x)->value.context.parent) #define sexp_context_saves(x) ((x)->value.context.saves) #define sexp_context_tailp(x) ((x)->value.context.tailp) #define sexp_context_tracep(x) ((x)->value.context.tailp) +#define sexp_context_top(x) (sexp_stack_top(sexp_context_stack(x))) + /****************************** arithmetic ****************************/ #define sexp_fx_add(a, b) ((sexp)(((sexp_sint_t)a)+((sexp_sint_t)b)-SEXP_FIXNUM_TAG)) @@ -444,9 +455,6 @@ void *sexp_realloc(sexp ctx, sexp x, size_t size); /****************************** utilities *****************************/ #define sexp_list1(x,a) sexp_cons((x), (a), SEXP_NULL) -#define sexp_list2(x,a,b) sexp_cons((x), (a), sexp_cons((x), (b), SEXP_NULL)) -#define sexp_list3(x,a,b,c) sexp_cons((x), (a), sexp_cons((x), (b), sexp_cons((x), (c), SEXP_NULL))) -#define sexp_list4(x,a,b,c,d) sexp_cons((x), (a), sexp_cons((x), (b), sexp_cons((x), (c), sexp_cons((x), (d), SEXP_NULL)))) #define sexp_push(ctx, ls, x) ((ls) = sexp_cons((ctx), (x), (ls))) #define sexp_insert(ctx, ls, x) ((sexp_memq(NULL, (x), (ls)) != SEXP_FALSE) ? (ls) : sexp_push((ctx), (ls), (x))) @@ -481,6 +489,7 @@ void *sexp_realloc(sexp ctx, sexp x, size_t size); sexp sexp_alloc_tagged(sexp ctx, size_t size, sexp_uint_t tag); sexp sexp_cons(sexp ctx, sexp head, sexp tail); +sexp sexp_list2(sexp ctx, sexp a, sexp b); sexp sexp_equalp (sexp ctx, sexp a, sexp b); sexp sexp_listp(sexp ctx, sexp obj); sexp sexp_reverse(sexp ctx, sexp ls); From 54baeaca36d1fe1405b9374d1ff2727d4dd20951 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Wed, 10 Jun 2009 00:38:15 +0900 Subject: [PATCH 113/154] don't sweep the free-list elements! implementing heap expansion w/ realloc. realloc is always giving back the same pointer right now, so pointer adjusting not tested yet. --- gc.c | 242 +++++++++++++++++++++++++++++++++++++++++++++++++---------- 1 file changed, 202 insertions(+), 40 deletions(-) diff --git a/gc.c b/gc.c index afb57970..49caa5fb 100644 --- a/gc.c +++ b/gc.c @@ -1,10 +1,11 @@ -/* gc.c -- simple garbage collector */ +/* gc.c -- simple mark&sweep garbage collector */ /* Copyright (c) 2009 Alex Shinn. All rights reserved. */ /* BSD-style license: http://synthcode.com/license.txt */ #include "sexp.h" -#define SEXP_INITIAL_HEAP_SIZE 50000 +#define SEXP_INITIAL_HEAP_SIZE 40000 +#define SEXP_MAXIMUM_HEAP_SIZE 0 #define SEXP_MINIMUM_OBJECT_SIZE (sexp_sizeof(flonum)) static char* sexp_heap; @@ -49,15 +50,16 @@ void sexp_mark (sexp x) { struct sexp_gc_var_t *saves; loop: if (((char*)x < sexp_heap) || ((char*)x >= sexp_heap_end)) { - if (x && sexp_pointerp(x) && (sexp_pointer_tag(x) != SEXP_OPCODE)) + if (x && sexp_pointerp(x) && (sexp_pointer_tag(x) != SEXP_OPCODE) + && (sexp_pointer_tag(x) != SEXP_CORE)) fprintf(stderr, "--------------- outside heap: %p (%x) ------------------\n", x, sexp_pointer_tag(x)); return; } if ((! x) || (! sexp_pointerp(x)) || sexp_gc_mark(x)) return; sexp_gc_mark(x) = 1; - fprintf(stderr, "----------------- marking %p (%x) --------------------\n", - x, sexp_pointer_tag(x)); +/* fprintf(stderr, "----------------- marking %p (%x) --------------------\n", */ +/* x, sexp_pointer_tag(x)); */ switch (sexp_pointer_tag(x)) { case SEXP_PAIR: sexp_mark(sexp_car(x)); @@ -153,6 +155,88 @@ void sexp_mark (sexp x) { } } +#define _adjust(x) if (x && (sexp_pointerp(x)) && (start <= (char*)x) && (((char*)x) <= end)) x = (sexp) (((char*)x)+offset) + +void sexp_adjust_pointers (sexp x, char* start, char* end, size_t offset) { + sexp *data; + sexp_uint_t i; + struct sexp_gc_var_t *saves; + switch (sexp_pointer_tag(x)) { + case SEXP_PAIR: + _adjust(sexp_car(x)); _adjust(sexp_cdr(x)); break; + case SEXP_STACK: + data = sexp_stack_data(x); + for (i=sexp_stack_top(x)-1; i>=0; i--) + _adjust(data[i]); + break; + case SEXP_VECTOR: + data = sexp_vector_data(x); + for (i=sexp_vector_length(x)-1; i>=0; i--) + _adjust(data[i]); + break; + case SEXP_SYMBOL: + _adjust(sexp_symbol_string(x)); break; + case SEXP_BYTECODE: + _adjust(sexp_bytecode_literals(x)); break; + case SEXP_ENV: + _adjust(sexp_env_lambda(x)); + _adjust(sexp_env_bindings(x)); + _adjust(sexp_env_parent(x)); + break; + case SEXP_PROCEDURE: + _adjust(sexp_procedure_code(x)); _adjust(sexp_procedure_vars(x)); break; + case SEXP_MACRO: + _adjust(sexp_macro_proc(x)); _adjust(sexp_macro_env(x)); break; + case SEXP_SYNCLO: + _adjust(sexp_synclo_free_vars(x)); + _adjust(sexp_synclo_expr(x)); + _adjust(sexp_synclo_env(x)); + break; + case SEXP_OPCODE: + _adjust(sexp_opcode_proc(x)); + _adjust(sexp_opcode_default(x)); + _adjust(sexp_opcode_data(x)); + break; + case SEXP_IPORT: + case SEXP_OPORT: + _adjust(sexp_port_cookie(x)); + case SEXP_LAMBDA: + _adjust(sexp_lambda_name(x)); + _adjust(sexp_lambda_params(x)); + _adjust(sexp_lambda_locals(x)); + _adjust(sexp_lambda_defs(x)); + _adjust(sexp_lambda_flags(x)); + _adjust(sexp_lambda_body(x)); + _adjust(sexp_lambda_fv(x)); + _adjust(sexp_lambda_sv(x)); + _adjust(sexp_lambda_body(x)); + break; + case SEXP_CND: + _adjust(sexp_cnd_test(x)); + _adjust(sexp_cnd_fail(x)); + _adjust(sexp_cnd_pass(x)); + break; + case SEXP_SET: + _adjust(sexp_set_var(x)); _adjust(sexp_set_value(x)); break; + case SEXP_REF: + _adjust(sexp_ref_name(x)); _adjust(sexp_ref_cell(x)); break; + case SEXP_SEQ: + _adjust(sexp_seq_ls(x)); break; + case SEXP_LIT: + _adjust(sexp_lit_value(x)); break; + case SEXP_CONTEXT: + _adjust(sexp_context_env(x)); + _adjust(sexp_context_bc(x)); + _adjust(sexp_context_fv(x)); + _adjust(sexp_context_lambda(x)); + _adjust(sexp_context_parent(x)); + for (saves=sexp_context_saves(x); saves; saves=saves->next) + if (saves->var) _adjust(*(saves->var)); + _adjust(sexp_context_stack(x)); + break; + } +} + void simple_write (sexp obj, int depth, FILE *out) { unsigned long len, c, res; long i=0; @@ -161,7 +245,7 @@ void simple_write (sexp obj, int depth, FILE *out) { if (! obj) { fputs("#", out); - } if (! sexp_pointerp(obj)) { + } else if (! sexp_pointerp(obj)) { if (sexp_integerp(obj)) { fprintf(out, "%ld", sexp_unbox_integer(obj)); } else if (sexp_charp(obj)) { @@ -334,10 +418,15 @@ void simple_write (sexp obj, int depth, FILE *out) { } void sexp_show_free_list (sexp ctx) { - sexp p=sexp_free_list; + sexp p=sexp_free_list, prev=NULL; fputs("free-list:", stderr); while (p && sexp_pairp(p) && ((char*) p < sexp_heap_end)) { - fprintf(stderr, " %p-%p", p, p+(sexp_uint_t)sexp_car(p)); + if (p < prev) { + fprintf(stderr, " \x1B[31m%p-%p\x1B[0m", p, ((char*)p)+(sexp_uint_t)sexp_car(p)); + } else { + fprintf(stderr, " %p-%p", p, ((char*)p)+(sexp_uint_t)sexp_car(p)); + } + prev = (sexp) (((char*)p)+(sexp_uint_t)sexp_car(p)); p = sexp_cdr(p); } putc('\n', stderr); @@ -346,33 +435,36 @@ void sexp_show_free_list (sexp ctx) { sexp sexp_sweep (sexp ctx) { sexp_uint_t freed=0, size; sexp p=(sexp)(sexp_heap+sexp_align(SEXP_MINIMUM_OBJECT_SIZE, 4)); - sexp f1=sexp_free_list, f2; + sexp q=sexp_free_list, r; /* scan over the whole heap */ - while ((char*)p size) ? cur_size : size) * 2, 4); + /* fprintf(stderr, "************* growing heap *************\n"); */ + if (SEXP_MAXIMUM_HEAP_SIZE && (new_size > SEXP_MAXIMUM_HEAP_SIZE)) { + fprintf(stderr, "************* heap too large *************\n"); + return 0; + } + if (! (tmp1 = realloc(sexp_heap, new_size))) { + fprintf(stderr, "************* couldn't realloc *************\n"); + return 0; + } + if (tmp1 != sexp_heap) { + sexp_adjust_heap(tmp1, tmp1+cur_size, tmp1-sexp_heap, new_size); + tmp2 = sexp_heap; + sexp_heap = tmp1; + free(tmp2); + } else { + for (q = sexp_free_list; + sexp_cdr(q) && sexp_pairp(sexp_cdr(q)); + q = sexp_cdr(q)) + ; + sexp_cdr(q) = (sexp) sexp_heap_end; + q = sexp_cdr(q); + sexp_pointer_tag(q) = SEXP_PAIR; + sexp_car(q) = (sexp) (new_size - cur_size); + sexp_cdr(q) = SEXP_NULL; + } + sexp_heap_end = sexp_heap + new_size; + return 1; +} + +void* sexp_try_alloc (sexp ctx, size_t size) { sexp ls1, ls2, ls3; - size = sexp_align(size, 4); - try_alloc: ls1 = sexp_free_list; ls2 = sexp_cdr(ls1); for (ls2=sexp_cdr(ls1); sexp_pairp(ls2); ) { @@ -408,21 +559,32 @@ void *sexp_alloc (sexp ctx, size_t size) { } else { /* take the whole chunk */ sexp_cdr(ls1) = sexp_cdr(ls2); } - bzero((void*)ls2, size); + bzero((void*)ls2, size); /* maybe not needed */ return ls2; } - ls1=ls2; - ls2=sexp_cdr(ls2); + ls1 = ls2; + ls2 = sexp_cdr(ls2); } - if ((! tries) && (sexp_unbox_integer(sexp_gc(ctx)) >= size)) { - tries++; - goto try_alloc; - } else { - fprintf(stderr, - "chibi: out of memory trying to allocate %ld bytes, aborting\n", - size); - exit(70); + return NULL; +} + +void* sexp_alloc (sexp ctx, size_t size) { + void *res; + size = sexp_align(size, 4); + res = sexp_try_alloc(ctx, size); + if (! res) { + if (sexp_unbox_integer(sexp_gc(ctx)) >= size) + res = sexp_try_alloc(ctx, size); + if ((! res) && sexp_grow_heap(ctx, size)) + res = sexp_try_alloc(ctx, size); + if (! res) { + fprintf(stderr, + "chibi: out of memory trying to allocate %ld bytes, aborting\n", + size); + exit(70); + } } + return res; } void sexp_gc_init () { @@ -438,6 +600,6 @@ void sexp_gc_init () { sexp_car(next) = (sexp) (SEXP_INITIAL_HEAP_SIZE - sexp_align(sexp_sizeof(pair), 4)); sexp_cdr(next) = SEXP_NULL; - fprintf(stderr, "heap: %p - %p, next: %p\n", sexp_heap, sexp_heap_end, next); + /* fprintf(stderr, "heap: %p - %p, next: %p\n", sexp_heap, sexp_heap_end, next); */ } From bafd9ebd29fb6d7dba46e5e474efe1676a881e15 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Wed, 10 Jun 2009 15:17:15 +0900 Subject: [PATCH 114/154] merging adjacent free chunks during the sweep phase --- gc.c | 30 ++++++++++++++++++++++++++---- 1 file changed, 26 insertions(+), 4 deletions(-) diff --git a/gc.c b/gc.c index 49caa5fb..e4ad82f0 100644 --- a/gc.c +++ b/gc.c @@ -4,6 +4,7 @@ #include "sexp.h" +/* #define SEXP_INITIAL_HEAP_SIZE (3*1024*1024) */ #define SEXP_INITIAL_HEAP_SIZE 40000 #define SEXP_MAXIMUM_HEAP_SIZE 0 #define SEXP_MINIMUM_OBJECT_SIZE (sexp_sizeof(flonum)) @@ -452,10 +453,31 @@ sexp sexp_sweep (sexp ctx) { /* simple_write(p, 1, stderr); */ /* fprintf(stderr, "\x1B[0m\n"); */ freed += size; - sexp_pointer_tag(p) = SEXP_PAIR; - sexp_car(p) = (sexp)size; - sexp_cdr(p) = r; - sexp_cdr(q) = p; + if (((((char*)q)+(sexp_uint_t)sexp_car(q)) == (char*)p) + && (q != sexp_free_list)) { + /* merge q with p */ + if (r && sexp_pairp(r) && ((((char*)p)+size) == (char*)r)) { + /* ... and with r */ + sexp_car(q) + = (sexp)(size+(sexp_uint_t)sexp_car(q)+(sexp_uint_t)sexp_car(r)); + sexp_cdr(q) = sexp_cdr(r); + r = sexp_cdr(r); + } else { + sexp_car(q) = (sexp)(size+(sexp_uint_t)sexp_car(q)); + } + } else { + sexp_pointer_tag(p) = SEXP_PAIR; + if (r && sexp_pairp(r) && ((((char*)p)+size) == (char*)r)) { + /* merge p with r */ + sexp_car(p) = (sexp)(size+(sexp_uint_t)sexp_car(r)); + sexp_cdr(p) = sexp_cdr(r); + r = p; + } else { + sexp_car(p) = (sexp)size; + sexp_cdr(p) = r; + } + sexp_cdr(q) = p; + } } else { /* fprintf(stderr, "\x1B[32msaving %lu bytes @ %p (%x) ", size, p, sexp_pointer_tag(p)); */ /* simple_write(p, 1, stderr); */ From cce116bc0a0cdf161d77aeeaa5ded88914f27a5c Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 11 Jun 2009 23:02:30 +0900 Subject: [PATCH 115/154] progress --- debug.c | 2 +- eval.c | 49 +++++++++---------- gc.c | 148 ++++++++++++++++++++++++++++++++++++++++++++++++-------- main.c | 1 + sexp.c | 78 ++++++++++++++++++++++++----- sexp.h | 66 ++++++++++++++++--------- 6 files changed, 265 insertions(+), 79 deletions(-) diff --git a/debug.c b/debug.c index f39ba635..cd329db9 100644 --- a/debug.c +++ b/debug.c @@ -20,7 +20,7 @@ static const char* reverse_opcode_names[] = "NEWLINE", "FLUSH-OUTPUT", "READ", "READ-CHAR", "PEEK-CHAR", "RET", "DONE", }; -static sexp sexp_disasm (sexp bc, sexp out) { +static sexp sexp_disasm (sexp ctx, sexp bc, sexp out) { unsigned char *ip, opcode; if (sexp_procedurep(bc)) bc = sexp_procedure_code(bc); diff --git a/eval.c b/eval.c index ba4aa3d8..d9e8ac88 100644 --- a/eval.c +++ b/eval.c @@ -251,7 +251,7 @@ static sexp sexp_make_context(sexp ctx, sexp stack, sexp env) { if (ctx) sexp_gc_preserve(ctx, res, save_res); res = sexp_alloc_type(ctx, context, SEXP_CONTEXT); if ((! stack) || (stack == SEXP_FALSE)) { - stack = sexp_alloc_tagged(ctx, sizeof(sexp)*INIT_STACK_SIZE, SEXP_STACK); + stack = sexp_alloc_tagged(ctx, sexp_sizeof(stack)+sizeof(sexp)*INIT_STACK_SIZE, SEXP_STACK); sexp_stack_length(stack) = INIT_STACK_SIZE; sexp_stack_top(stack) = 0; } @@ -451,7 +451,7 @@ static sexp analyze_lambda (sexp ctx, sexp x) { sexp_gc_preserve(ctx, tmp, s_tmp); sexp_gc_preserve(ctx, value, s_value); sexp_gc_preserve(ctx, defs, s_defs); - /* verify syntax */ + /* verify syntax - XXXX release! */ if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) return sexp_compile_error(ctx, "bad lambda syntax", x); for (ls=sexp_cadr(x); sexp_pairp(ls); ls=sexp_cdr(ls)) @@ -462,25 +462,19 @@ static sexp analyze_lambda (sexp ctx, sexp x) { /* build lambda and analyze body */ res = sexp_make_lambda(ctx, sexp_cadr(x)); ctx = sexp_make_child_context(ctx, res); - sexp_context_env(ctx) - = extend_env(ctx, - sexp_context_env(ctx), - sexp_flatten_dot(ctx, sexp_lambda_params(res)), - res); + tmp = sexp_flatten_dot(ctx, sexp_lambda_params(res)); + sexp_context_env(ctx) = extend_env(ctx, sexp_context_env(ctx), tmp, res); sexp_env_lambda(sexp_context_env(ctx)) = res; body = analyze_seq(ctx, sexp_cddr(x)); analyze_check_exception(body); /* delayed analyze internal defines */ + defs = SEXP_NULL; for (ls=sexp_lambda_defs(res); sexp_pairp(ls); ls=sexp_cdr(ls)) { tmp = sexp_car(ls); if (sexp_pairp(sexp_cadr(tmp))) { name = sexp_caadr(tmp); - value = analyze_lambda(ctx, - sexp_cons(ctx, - SEXP_VOID, - sexp_cons(ctx, - sexp_cdadr(tmp), - sexp_cddr(tmp)))); + tmp = sexp_cons(ctx, sexp_cdadr(tmp), sexp_cddr(tmp)); + value = analyze_lambda(ctx, sexp_cons(ctx, SEXP_VOID, tmp)); } else { name = sexp_cadr(tmp); value = analyze(ctx, sexp_caddr(tmp)); @@ -1709,6 +1703,7 @@ sexp vm (sexp proc, sexp ctx) { end_loop: sexp_gc_release(ctx, self, s_self); + sexp_context_top(ctx) = top; return _ARG1; } @@ -1767,26 +1762,28 @@ sexp sexp_load (sexp ctx, sexp source, sexp env) { sexp_gc_preserve(ctx, x, s_x); sexp_gc_preserve(ctx, in, s_in); ctx2 = sexp_make_context(ctx, NULL, env); + sexp_context_parent(ctx2) = ctx; out = env_global_ref(env, the_cur_err_symbol, SEXP_FALSE); tmp = sexp_env_bindings(env); sexp_context_tailp(ctx2) = 0; in = sexp_open_input_file(ctx, source); if (sexp_exceptionp(in)) { sexp_print_exception(ctx, in, out); - return in; - } - while ((x=sexp_read(ctx, in)) != (sexp) SEXP_EOF) { - res = eval_in_context(ctx2, x); - if (sexp_exceptionp(res)) - break; - } - if (x == SEXP_EOF) - res = SEXP_VOID; - sexp_close_port(ctx, in); + res = in; + } else { + while ((x=sexp_read(ctx, in)) != (sexp) SEXP_EOF) { + res = eval_in_context(ctx2, x); + if (sexp_exceptionp(res)) + break; + } + if (x == SEXP_EOF) + res = SEXP_VOID; + sexp_close_port(ctx, in); #if USE_WARN_UNDEFS - if (sexp_oportp(out)) - sexp_warn_undefs(sexp_env_bindings(env), tmp, out); + if (sexp_oportp(out)) + sexp_warn_undefs(sexp_env_bindings(env), tmp, out); #endif + } sexp_gc_release(ctx, ctx2, s_ctx2); return res; } @@ -1957,10 +1954,10 @@ sexp apply (sexp ctx, sexp proc, sexp args) { stack[--offset] = sexp_car(ls); stack[top] = sexp_make_integer(top); top++; + sexp_context_top(ctx) = top + 3; stack[top++] = sexp_make_integer(sexp_bytecode_data(final_resumer)); stack[top++] = sexp_make_vector(ctx, 0, SEXP_VOID); stack[top++] = sexp_make_integer(0); - sexp_context_top(ctx) = top; return vm(proc, ctx); } diff --git a/gc.c b/gc.c index e4ad82f0..4e5b8c48 100644 --- a/gc.c +++ b/gc.c @@ -13,11 +13,13 @@ static char* sexp_heap; static char* sexp_heap_end; static sexp sexp_free_list; -sexp_uint_t sexp_allocated_bytes (sexp x) { +static sexp* stack_base; + +sexp_uint_t sexp_allocated_bytes0 (sexp x) { switch (sexp_pointer_tag(x)) { case SEXP_PAIR: return sexp_sizeof(pair); case SEXP_SYMBOL: return sexp_sizeof(symbol); - case SEXP_STRING: return sexp_sizeof(string)+sexp_string_length(x); + case SEXP_STRING: return sexp_sizeof(string)+sexp_string_length(x)+1; case SEXP_VECTOR: return sexp_sizeof(vector)+(sexp_vector_length(x)*sizeof(sexp)); case SEXP_STACK: @@ -45,6 +47,21 @@ sexp_uint_t sexp_allocated_bytes (sexp x) { } } +sexp_uint_t sexp_allocated_bytes (sexp x) { + sexp_uint_t res, *len_ptr; + sexp t; + if ((! sexp_pointerp(x)) || (sexp_pointer_tag(x) > SEXP_CONTEXT)) + return sexp_align(1, 4); + t = &(sexp_types[sexp_pointer_tag(x)]); + len_ptr = (sexp_uint_t*) (((char*)x) + sexp_type_size_off(t)); + res = sexp_type_size_base(t) + len_ptr[0] * sexp_type_size_scale(t); + if (res != sexp_allocated_bytes0(x)) { + fprintf(stderr, "allocated bytes differ for tag %d @ %p: switch: %lu, data: %lu\n", sexp_pointer_tag(x), x, sexp_allocated_bytes0(x), res); + /* exit(1); */ + } + return res; +} + void sexp_mark (sexp x) { sexp *data; sexp_uint_t i; @@ -433,8 +450,20 @@ void sexp_show_free_list (sexp ctx) { putc('\n', stderr); } -sexp sexp_sweep (sexp ctx) { - sexp_uint_t freed=0, size; +void validate_free_list (sexp ctx) { + sexp p=sexp_free_list, prev=NULL; + while (p && sexp_pairp(p) && ((char*) p < sexp_heap_end)) { + if (((char*)p < sexp_heap) || ((char*)p >= sexp_heap_end)) + fprintf(stderr, " \x1B[31mfree-list outside heap: %p prev: %p\x1B[0m", p, prev); + if (p < prev) + fprintf(stderr, " \x1B[31mfree-list out of order at: %p prev: %p cdr: %p\x1B[0m", p, prev, sexp_cdr(p)); + prev = (sexp) (((char*)p)+(sexp_uint_t)sexp_car(p)); + p = sexp_cdr(p); + } +} + +void validate_heap (sexp ctx) { + sexp_uint_t size; sexp p=(sexp)(sexp_heap+sexp_align(SEXP_MINIMUM_OBJECT_SIZE, 4)); sexp q=sexp_free_list, r; /* scan over the whole heap */ @@ -448,53 +477,128 @@ sexp sexp_sweep (sexp ctx) { continue; } size = sexp_align(sexp_allocated_bytes(p), 4); + if (sexp_pointer_tag(p) == 0) { + fprintf(stderr, "bare object found at %p\n", p); + } else if (sexp_pointer_tag(p) == 0) { + fprintf(stderr, "type object found at %p\n", p); + } else if (sexp_pointer_tag(p) > SEXP_CONTEXT) { + fprintf(stderr, "bad type at %p: %d\n", p, sexp_pointer_tag(p)); + } + p = (sexp) (((char*)p)+size); + } +} + +void validate_gc_vars (sexp ctx) { + struct sexp_gc_var_t *saves, *prev=NULL; + if (! ctx) + return; + for (saves=sexp_context_saves(ctx); saves; saves=saves->next) { +/* if (saves->var) { */ +/* if (((char*)*(saves->var) < sexp_heap) */ +/* || ((char*)*(saves->var) >= sexp_heap_end)) */ +/* fprintf(stderr, "bad variable in gc var: %p\n", *(saves->var)); */ +/* } */ + if (prev && (prev > saves)) { + fprintf(stderr, "gc vars out of order: %p > %p\n", prev, saves); + return; + } else if (prev == saves) { + fprintf(stderr, "loop in gc vars at %p\n", saves); + return; + } + prev = saves; + } +} + +void validate_freed_pointer (sexp x, sexp *start) { + sexp *p; + for (p=start; p max_freed) + max_freed = freed; } else { /* fprintf(stderr, "\x1B[32msaving %lu bytes @ %p (%x) ", size, p, sexp_pointer_tag(p)); */ /* simple_write(p, 1, stderr); */ /* fprintf(stderr, "\x1B[0m\n"); */ sexp_gc_mark(p) = 0; + p = (sexp) (((char*)p)+size); } - p = (sexp) (((char*)p)+size); } -/* fprintf(stderr, "**************** freed %ld bytes ****************\n", freed); */ - return sexp_make_integer(freed); + fprintf(stderr, "**************** freed %ld bytes, max %ld ****************\n", sum_freed, max_freed); + return sexp_make_integer(max_freed); } extern sexp continuation_resumer, final_resumer; sexp sexp_gc (sexp ctx) { int i; - /* fprintf(stderr, "************* garbage collecting *************\n"); */ + fprintf(stderr, "************* garbage collecting *************\n"); /* sexp_show_free_list(ctx); */ sexp_mark(continuation_resumer); sexp_mark(final_resumer); @@ -507,7 +611,6 @@ sexp sexp_gc (sexp ctx) { void sexp_adjust_heap (char *start, char *end, size_t offset, size_t new_size) { sexp p=(sexp)(start+sexp_align(SEXP_MINIMUM_OBJECT_SIZE, 4)); sexp q=(sexp)(((char*)sexp_free_list)+offset), r; - /* fprintf(stderr, "************* adjusting heap *************\n"); */ while (((char*)p) < end) { /* find the preceding and succeeding free list pointers */ for (r=sexp_cdr(q); r && sexp_pairp(r) && (r size) ? cur_size : size) * 2, 4); - /* fprintf(stderr, "************* growing heap *************\n"); */ + fprintf(stderr, "************* growing heap *************\n"); + validate_heap(ctx); if (SEXP_MAXIMUM_HEAP_SIZE && (new_size > SEXP_MAXIMUM_HEAP_SIZE)) { fprintf(stderr, "************* heap too large *************\n"); return 0; @@ -547,6 +651,7 @@ int sexp_grow_heap (sexp ctx, size_t size) { return 0; } if (tmp1 != sexp_heap) { + fprintf(stderr, "************* adjusting heap pointers *************\n"); sexp_adjust_heap(tmp1, tmp1+cur_size, tmp1-sexp_heap, new_size); tmp2 = sexp_heap; sexp_heap = tmp1; @@ -592,6 +697,9 @@ void* sexp_try_alloc (sexp ctx, size_t size) { void* sexp_alloc (sexp ctx, size_t size) { void *res; + validate_heap(ctx); + validate_free_list(ctx); + validate_gc_vars(ctx); size = sexp_align(size, 4); res = sexp_try_alloc(ctx, size); if (! res) { @@ -606,6 +714,7 @@ void* sexp_alloc (sexp ctx, size_t size) { exit(70); } } + /* fprintf(stderr, "sexp_alloc %lu => %p\n", size, res); */ return res; } @@ -622,6 +731,7 @@ void sexp_gc_init () { sexp_car(next) = (sexp) (SEXP_INITIAL_HEAP_SIZE - sexp_align(sexp_sizeof(pair), 4)); sexp_cdr(next) = SEXP_NULL; - /* fprintf(stderr, "heap: %p - %p, next: %p\n", sexp_heap, sexp_heap_end, next); */ + stack_base = &next; + fprintf(stderr, "heap: %p - %p, next: %p\n", sexp_heap, sexp_heap_end, next); } diff --git a/main.c b/main.c index 830e89f7..a9d12e04 100644 --- a/main.c +++ b/main.c @@ -18,6 +18,7 @@ void repl (sexp ctx) { sexp_print_exception(ctx, obj, err); } else { tmp = sexp_env_bindings(env); + sexp_context_top(ctx) = 0; res = eval_in_context(ctx, obj); #if USE_WARN_UNDEFS sexp_warn_undefs(sexp_env_bindings(env), tmp, err); diff --git a/sexp.c b/sexp.c index 04745ee1..8f7c2f24 100644 --- a/sexp.c +++ b/sexp.c @@ -56,6 +56,38 @@ sexp sexp_alloc_tagged(sexp ctx, size_t size, sexp_uint_t tag) { return res; } +static struct sexp_struct sexp_types[] = { + {.tag=SEXP_TYPE, .value={.type={SEXP_OBJECT, 0, 0, 0, 0, 0, 0, 0, "object"}}}, + {.tag=SEXP_TYPE, .value={.type={SEXP_TYPE, 0, 0, 0, 0, sexp_sizeof(type), 0, 0, "type"}}}, + {.tag=SEXP_TYPE, .value={.type={SEXP_FIXNUM, 0, 0, 0, 0, 0, 0, 0, "fixnum"}}}, + {.tag=SEXP_TYPE, .value={.type={SEXP_CHAR, 0, 0, 0, 0, 0, 0, 0, "char"}}}, + {.tag=SEXP_TYPE, .value={.type={SEXP_BOOLEAN, 0, 0, 0, 0, 0, 0, 0, "boolean"}}}, + {.tag=SEXP_TYPE, .value={.type={SEXP_PAIR, 0, 0, 0, 0, sexp_sizeof(pair), 0, 0, "pair"}}}, + {.tag=SEXP_TYPE, .value={.type={SEXP_SYMBOL, 0, 0, 0, 0, sexp_sizeof(symbol), 0, 0, "symbol"}}}, + {.tag=SEXP_TYPE, .value={.type={SEXP_STRING, 0, 0, 0, 0, sexp_sizeof(string)+1, offsetof(struct sexp_struct, value.string.length), 1, "string"}}}, + {.tag=SEXP_TYPE, .value={.type={SEXP_VECTOR, 0, 0, 0, 0, sexp_sizeof(vector), offsetof(struct sexp_struct, value.vector.length), 4, "vector"}}}, + {.tag=SEXP_TYPE, .value={.type={SEXP_FLONUM, 0, 0, 0, 0, sexp_sizeof(flonum), 0, 0, "flonum"}}}, + {.tag=SEXP_TYPE, .value={.type={SEXP_BIGNUM, 0, 0, 0, 0, sexp_sizeof(bignum), offsetof(struct sexp_struct, value.bignum.length), 4, "bignum"}}}, + {.tag=SEXP_TYPE, .value={.type={SEXP_IPORT, 0, 0, 0, 0, sexp_sizeof(port), 0, 0, "input-port"}}}, + {.tag=SEXP_TYPE, .value={.type={SEXP_OPORT, 0, 0, 0, 0, sexp_sizeof(port), 0, 0, "output-port"}}}, + {.tag=SEXP_TYPE, .value={.type={SEXP_EXCEPTION, 0, 0, 0, 0, sexp_sizeof(exception), 0, 0, "exception"}}}, + {.tag=SEXP_TYPE, .value={.type={SEXP_PROCEDURE, 0, 0, 0, 0, sexp_sizeof(procedure), 0, 0, "procedure"}}}, + {.tag=SEXP_TYPE, .value={.type={SEXP_MACRO, 0, 0, 0, 0, sexp_sizeof(macro), 0, 0, "macro"}}}, + {.tag=SEXP_TYPE, .value={.type={SEXP_SYNCLO, 0, 0, 0, 0, sexp_sizeof(synclo), 0, 0, "syntactic-closure"}}}, + {.tag=SEXP_TYPE, .value={.type={SEXP_ENV, 0, 0, 0, 0, sexp_sizeof(env), 0, 0, "environment"}}}, + {.tag=SEXP_TYPE, .value={.type={SEXP_BYTECODE, 0, 0, 0, 0, sexp_sizeof(bytecode), offsetof(struct sexp_struct, value.bytecode.length), 1, "bytecode"}}}, + {.tag=SEXP_TYPE, .value={.type={SEXP_CORE, 0, 0, 0, 0, sexp_sizeof(core), 0, 0, "core-form"}}}, + {.tag=SEXP_TYPE, .value={.type={SEXP_OPCODE, 0, 0, 0, 0, sexp_sizeof(opcode), 0, 0, "opcode"}}}, + {.tag=SEXP_TYPE, .value={.type={SEXP_LAMBDA, 0, 0, 0, 0, sexp_sizeof(lambda), 0, 0, "lambda"}}}, + {.tag=SEXP_TYPE, .value={.type={SEXP_CND, 0, 0, 0, 0, sexp_sizeof(cnd), 0, 0, "conditoinal"}}}, + {.tag=SEXP_TYPE, .value={.type={SEXP_REF, 0, 0, 0, 0, sexp_sizeof(ref), 0, 0, "reference"}}}, + {.tag=SEXP_TYPE, .value={.type={SEXP_SET, 0, 0, 0, 0, sexp_sizeof(set), 0, 0, "set!"}}}, + {.tag=SEXP_TYPE, .value={.type={SEXP_SEQ, 0, 0, 0, 0, sexp_sizeof(seq), 0, 0, "sequence"}}}, + {.tag=SEXP_TYPE, .value={.type={SEXP_LIT, 0, 0, 0, 0, sexp_sizeof(lit), 0, 0, "literal"}}}, + {.tag=SEXP_TYPE, .value={.type={SEXP_STACK, 0, 0, 0, 0, sexp_sizeof(stack), offsetof(struct sexp_struct, value.stack.length), 4, "stack"}}}, + {.tag=SEXP_TYPE, .value={.type={SEXP_CONTEXT, 0, 0, 0, 0, sexp_sizeof(context), 0, 0, "context"}}}, +}; + #if ! USE_BOEHM #if USE_MALLOC void sexp_deep_free (sexp ctx, sexp obj) { @@ -183,12 +215,19 @@ sexp sexp_print_exception (sexp ctx, sexp exn, sexp out) { } static sexp sexp_read_error (sexp ctx, char *msg, sexp irritants, sexp port) { - sexp name = (sexp_port_name(port) - ? sexp_c_string(ctx, sexp_port_name(port), -1) : SEXP_FALSE); - return sexp_make_exception(ctx, the_read_error_symbol, - sexp_c_string(ctx, msg, -1), - irritants, SEXP_FALSE, name, - sexp_make_integer(sexp_port_line(port))); + sexp res; + sexp_gc_var(ctx, name, s_name); + sexp_gc_var(ctx, str, s_str); + sexp_gc_preserve(ctx, name, s_name); + sexp_gc_preserve(ctx, str, s_str); + name = (sexp_port_name(port) + ? sexp_c_string(ctx, sexp_port_name(port), -1) : SEXP_FALSE); + str = sexp_c_string(ctx, msg, -1); + res = sexp_make_exception(ctx, the_read_error_symbol, + str, irritants, SEXP_FALSE, name, + sexp_make_integer(sexp_port_line(port))); + sexp_gc_release(ctx, name, s_name); + return res; } /*************************** list utilities ***************************/ @@ -390,7 +429,8 @@ sexp sexp_intern(sexp ctx, char *str) { struct huff_entry he; sexp_uint_t len, res=FNV_OFFSET_BASIS, space=3, newbits, bucket; char c, *p=str; - sexp sym, ls; + sexp ls; + sexp_gc_var(ctx, sym, s_sym); #if USE_HUFF_SYMS res = 0; @@ -418,9 +458,11 @@ sexp sexp_intern(sexp ctx, char *str) { return sexp_car(ls); /* not found, make a new symbol */ + sexp_gc_preserve(ctx, sym, s_sym); sym = sexp_alloc_type(ctx, symbol, SEXP_SYMBOL); sexp_symbol_string(sym) = sexp_c_string(ctx, str, len); sexp_push(ctx, sexp_symbol_table[bucket], sym); + sexp_gc_release(ctx, sym, s_sym); return sym; } @@ -519,24 +561,30 @@ off_t sstream_seek (void *vec, off_t offset, int whence) { sexp sexp_make_input_string_port (sexp ctx, sexp str) { FILE *in; - sexp res, cookie; + sexp res; + sexp_gc_var(ctx, cookie, s_cookie); + sexp_gc_preserve(ctx, cookie, s_cookie); cookie = sexp_vector(ctx, 3, str, sexp_make_integer(sexp_string_length(str)), sexp_make_integer(0)); in = funopen(cookie, &sstream_read, NULL, &sstream_seek, NULL); res = sexp_make_input_port(ctx, in, NULL); sexp_port_cookie(res) = cookie; + sexp_gc_release(ctx, cookie, s_cookie); return res; } sexp sexp_make_output_string_port (sexp ctx) { FILE *out; - sexp res, size, cookie; + sexp res, size; + sexp_gc_var(ctx, cookie, s_cookie); + sexp_gc_preserve(ctx, cookie, s_cookie); size = sexp_make_integer(SEXP_INIT_STRING_PORT_SIZE); cookie = sexp_vector(ctx, 3, sexp_make_string(NULL, size, SEXP_VOID), size, sexp_make_integer(0)); out = funopen(cookie, NULL, &sstream_write, &sstream_seek, NULL); res = sexp_make_output_port(ctx, out, NULL); sexp_port_cookie(res) = cookie; + sexp_gc_release(ctx, cookie, s_cookie); return res; } @@ -697,6 +745,11 @@ void sexp_write (sexp obj, sexp out) { sexp_write_string(">", out); break; #endif + case SEXP_TYPE: + sexp_write_string("#", out); + break; case SEXP_STRING: sexp_write_char('"', out); i = sexp_string_length(obj); @@ -1015,8 +1068,11 @@ sexp sexp_read_raw (sexp ctx, sexp in) { /* case '0': case '1': case '2': case '3': case '4': */ /* case '5': case '6': case '7': case '8': case '9': */ case ';': - sexp_read_raw(ctx, in); /* discard */ - goto scan_loop; + tmp = sexp_read_raw(ctx, in); /* discard */ + if (sexp_exceptionp(tmp)) + res = tmp; + else + goto scan_loop; case '\\': c1 = sexp_read_char(in); res = sexp_read_symbol(ctx, in, c1, 0); diff --git a/sexp.h b/sexp.h index 6d4b8789..65823529 100644 --- a/sexp.h +++ b/sexp.h @@ -52,6 +52,7 @@ enum sexp_types { SEXP_OBJECT, + SEXP_TYPE, SEXP_FIXNUM, SEXP_CHAR, SEXP_BOOLEAN, @@ -84,7 +85,7 @@ enum sexp_types { typedef unsigned long sexp_uint_t; typedef long sexp_sint_t; -typedef char sexp_tag_t; +typedef unsigned char sexp_tag_t; typedef struct sexp_struct *sexp; struct sexp_gc_var_t { @@ -99,6 +100,12 @@ struct sexp_struct { union { /* basic types */ double flonum; + struct { + sexp_tag_t tag; + sexp_sint_t field_base, field_len_base, field_len_off, field_len_scale; + sexp_sint_t size_base, size_off, size_scale; + char *name; + } type; struct { sexp car, cdr; } pair; @@ -183,9 +190,9 @@ struct sexp_struct { sexp data[]; } stack; struct { - sexp bc, lambda, stack, env, fv, parent; struct sexp_gc_var_t *saves; sexp_uint_t pos, depth, tailp, tracep; + sexp bc, lambda, stack, env, fv, parent; } context; } value; }; @@ -218,29 +225,18 @@ struct sexp_struct { #else #define sexp_gc_var(ctx, x, y) \ - sexp x = SEXP_FALSE; \ - struct sexp_gc_var_t y = {0, 0}; + sexp x = SEXP_VOID; \ + struct sexp_gc_var_t y = {NULL, NULL}; + +#define sexp_gc_preserve(ctx, x, y) \ + do { \ + (y).var = &(x); \ + (y).next = sexp_context_saves(ctx); \ + sexp_context_saves(ctx) = &(y); \ + } while (0) -#define sexp_gc_preserve(ctx, x, y) ((y).var=&(x), \ - (y).next = sexp_context_saves(ctx), \ - sexp_context_saves(ctx) = &(y)) #define sexp_gc_release(ctx, x, y) (sexp_context_saves(ctx) = y.next) -#define sexp_with_gc_var1(ctx, x, body) \ - sexp_gc_var(ctx, x, _sexp_gcv1); \ - sexp_gc_preserve(ctx, x, _sexp_gcv1); \ - do {body} while (0); \ - sexp_gc_release(ctx, x, _sexp_gcv1); - -#define sexp_with_gc_var2(ctx, x, y, body) \ - sexp_gc_var(ctx, x, _sexp_gcv1); \ - sexp_gc_var(ctx, y, _sexp_gcv2); \ - sexp_gc_preserve(ctx, x, _sexp_gcv1); \ - sexp_gc_preserve(ctx, y, _sexp_gcv2); \ - do {body} while (0); \ - sexp_gc_release(ctx, x, _sexp_gcv1); \ - sexp_gc_release(ctx, y, _sexp_gcv2); - #if USE_MALLOC #define sexp_alloc(ctx, size) malloc(size) #define sexp_alloc_atomic(ctx, size) malloc(size) @@ -258,6 +254,21 @@ void *sexp_realloc(sexp ctx, sexp x, size_t size); #endif #endif +#define sexp_with_gc_var1(ctx, x, body) \ + sexp_gc_var(ctx, x, _sexp_gcv1); \ + sexp_gc_preserve(ctx, x, _sexp_gcv1); \ + do {body} while (0); \ + sexp_gc_release(ctx, x, _sexp_gcv1); + +#define sexp_with_gc_var2(ctx, x, y, body) \ + sexp_gc_var(ctx, x, _sexp_gcv1); \ + sexp_gc_var(ctx, y, _sexp_gcv2); \ + sexp_gc_preserve(ctx, x, _sexp_gcv1); \ + sexp_gc_preserve(ctx, y, _sexp_gcv2); \ + do {body} while (0); \ + sexp_gc_release(ctx, x, _sexp_gcv1); \ + sexp_gc_release(ctx, y, _sexp_gcv2); + #define sexp_align(n, bits) (((n)+(1<<(bits))-1)&(((sexp_uint_t)-1)-((1<<(bits))-1))) #define sexp_sizeof(x) (offsetof(struct sexp_struct, value) \ @@ -279,6 +290,7 @@ void *sexp_realloc(sexp ctx, sexp x, size_t size); #define sexp_check_tag(x,t) (sexp_pointerp(x) && (sexp_pointer_tag(x) == (t))) +#define sexp_typep(x) (sexp_check_tag(x, SEXP_TYPE)) #define sexp_pairp(x) (sexp_check_tag(x, SEXP_PAIR)) #define sexp_stringp(x) (sexp_check_tag(x, SEXP_STRING)) #define sexp_lsymbolp(x) (sexp_check_tag(x, SEXP_SYMBOL)) @@ -438,6 +450,16 @@ void *sexp_realloc(sexp ctx, sexp x, size_t size); #define sexp_context_top(x) (sexp_stack_top(sexp_context_stack(x))) +#define sexp_type_tag(x) ((x)->value.type.tag) +#define sexp_type_field_base(x) ((x)->value.type.field_base) +#define sexp_type_field_len_base(x) ((x)->value.type.field_len_base) +#define sexp_type_field_len_off(x) ((x)->value.type.field_len_off) +#define sexp_type_field_len_scale(x) ((x)->value.type.field_len_scale) +#define sexp_type_size_base(x) ((x)->value.type.size_base) +#define sexp_type_size_off(x) ((x)->value.type.size_off) +#define sexp_type_size_scale(x) ((x)->value.type.size_scale) +#define sexp_type_name(x) ((x)->value.type.name) + /****************************** arithmetic ****************************/ #define sexp_fx_add(a, b) ((sexp)(((sexp_sint_t)a)+((sexp_sint_t)b)-SEXP_FIXNUM_TAG)) From b636225da7fddf47ba9e4b37075fbdd4ca1b5d31 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Fri, 12 Jun 2009 17:35:57 +0900 Subject: [PATCH 116/154] fixing some stack pointer management bugs --- Makefile | 1 - eval.c | 156 +++++++++++++++++++++++++++++-------------------------- sexp.h | 2 + 3 files changed, 83 insertions(+), 76 deletions(-) diff --git a/Makefile b/Makefile index 6dc9b848..32b994e6 100644 --- a/Makefile +++ b/Makefile @@ -71,6 +71,5 @@ dist: cleaner rm -f chibi-scheme-`cat VERSION`.tgz mkdir chibi-scheme-`cat VERSION` for f in `hg manifest`; do mkdir -p chibi-scheme-`cat VERSION`/`dirname $$f`; ln -s `pwd`/$$f chibi-scheme-`cat VERSION`/$$f; done - cd chibi-scheme-`cat VERSION`; tar xzvf ../gc.tar.gz; mv gc[0-9].[0-9] gc tar cphzvf chibi-scheme-`cat VERSION`.tgz chibi-scheme-`cat VERSION` rm -rf chibi-scheme-`cat VERSION` diff --git a/eval.c b/eval.c index d9e8ac88..bb2517ed 100644 --- a/eval.c +++ b/eval.c @@ -446,11 +446,13 @@ static sexp analyze_lambda (sexp ctx, sexp x) { sexp_gc_var(ctx, tmp, s_tmp); sexp_gc_var(ctx, value, s_value); sexp_gc_var(ctx, defs, s_defs); + sexp_gc_var(ctx, ctx2, s_ctx2); sexp_gc_preserve(ctx, res, s_res); sexp_gc_preserve(ctx, body, s_body); sexp_gc_preserve(ctx, tmp, s_tmp); sexp_gc_preserve(ctx, value, s_value); sexp_gc_preserve(ctx, defs, s_defs); + sexp_gc_preserve(ctx, ctx2, s_ctx2); /* verify syntax - XXXX release! */ if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) return sexp_compile_error(ctx, "bad lambda syntax", x); @@ -461,11 +463,11 @@ static sexp analyze_lambda (sexp ctx, sexp x) { return sexp_compile_error(ctx, "duplicate parameter", x); /* build lambda and analyze body */ res = sexp_make_lambda(ctx, sexp_cadr(x)); - ctx = sexp_make_child_context(ctx, res); - tmp = sexp_flatten_dot(ctx, sexp_lambda_params(res)); - sexp_context_env(ctx) = extend_env(ctx, sexp_context_env(ctx), tmp, res); - sexp_env_lambda(sexp_context_env(ctx)) = res; - body = analyze_seq(ctx, sexp_cddr(x)); + ctx2 = sexp_make_child_context(ctx, res); + tmp = sexp_flatten_dot(ctx2, sexp_lambda_params(res)); + sexp_context_env(ctx2) = extend_env(ctx2, sexp_context_env(ctx2), tmp, res); + sexp_env_lambda(sexp_context_env(ctx2)) = res; + body = analyze_seq(ctx2, sexp_cddr(x)); analyze_check_exception(body); /* delayed analyze internal defines */ defs = SEXP_NULL; @@ -473,22 +475,23 @@ static sexp analyze_lambda (sexp ctx, sexp x) { tmp = sexp_car(ls); if (sexp_pairp(sexp_cadr(tmp))) { name = sexp_caadr(tmp); - tmp = sexp_cons(ctx, sexp_cdadr(tmp), sexp_cddr(tmp)); - value = analyze_lambda(ctx, sexp_cons(ctx, SEXP_VOID, tmp)); + tmp = sexp_cons(ctx2, sexp_cdadr(tmp), sexp_cddr(tmp)); + value = analyze_lambda(ctx2, sexp_cons(ctx2, SEXP_VOID, tmp)); } else { name = sexp_cadr(tmp); - value = analyze(ctx, sexp_caddr(tmp)); + value = analyze(ctx2, sexp_caddr(tmp)); } analyze_check_exception(value); - sexp_push(ctx, defs, sexp_make_set(ctx, analyze_var_ref(ctx, name), value)); + sexp_push(ctx2, defs, + sexp_make_set(ctx2, analyze_var_ref(ctx, name), value)); } if (sexp_pairp(defs)) { if (! sexp_seqp(body)) { - tmp = sexp_alloc_type(ctx, seq, SEXP_SEQ); - sexp_seq_ls(tmp) = sexp_list1(ctx, body); + tmp = sexp_alloc_type(ctx2, seq, SEXP_SEQ); + sexp_seq_ls(tmp) = sexp_list1(ctx2, body); body = tmp; } - sexp_seq_ls(body) = sexp_append2(ctx, defs, sexp_seq_ls(body)); + sexp_seq_ls(body) = sexp_append2(ctx2, defs, sexp_seq_ls(body)); } sexp_lambda_body(res) = body; sexp_gc_release(ctx, res, s_res); @@ -527,23 +530,23 @@ static sexp analyze_define (sexp ctx, sexp x) { sexp_push(ctx, sexp_lambda_sv(sexp_env_lambda(env)), name); sexp_push(ctx, sexp_lambda_locals(sexp_env_lambda(env)), name); sexp_push(ctx, sexp_lambda_defs(sexp_env_lambda(env)), x); - return SEXP_VOID; + res = SEXP_VOID; } else { env_cell_create(ctx, env, name, SEXP_VOID); + if (sexp_pairp(sexp_cadr(x))) { + tmp = sexp_cons(ctx, sexp_cdadr(x), sexp_cddr(x)); + tmp = sexp_cons(ctx, SEXP_VOID, tmp); + value = analyze_lambda(ctx, tmp); + } else + value = analyze(ctx, sexp_caddr(x)); + ref = analyze_var_ref(ctx, name); + if (sexp_exceptionp(ref)) + res = ref; + else if (sexp_exceptionp(value)) + res = value; + else + res = sexp_make_set(ctx, ref, value); } - if (sexp_pairp(sexp_cadr(x))) { - tmp = sexp_cons(ctx, sexp_cdadr(x), sexp_cddr(x)); - tmp = sexp_cons(ctx, SEXP_VOID, tmp); - value = analyze_lambda(ctx, tmp); - } else - value = analyze(ctx, sexp_caddr(x)); - ref = analyze_var_ref(ctx, name); - if (sexp_exceptionp(ref)) - res = ref; - else if (sexp_exceptionp(value)) - res = value; - else - res = sexp_make_set(ctx, ref, value); sexp_gc_release(ctx, ref, s_ref); return res; } @@ -626,56 +629,59 @@ static sexp analyze (sexp ctx, sexp object) { if (! cell && sexp_synclop(sexp_car(x))) cell = env_cell(sexp_synclo_env(sexp_car(x)), sexp_synclo_expr(sexp_car(x))); - if (! cell) return analyze_app(ctx, x); - op = sexp_cdr(cell); - if (sexp_corep(op)) { - switch (sexp_core_code(op)) { - case CORE_DEFINE: - res = analyze_define(ctx, x); break; - case CORE_SET: - res = analyze_set(ctx, x); break; - case CORE_LAMBDA: - res = analyze_lambda(ctx, x); break; - case CORE_IF: - res = analyze_if(ctx, x); break; - case CORE_BEGIN: - res = analyze_seq(ctx, sexp_cdr(x)); break; - case CORE_QUOTE: - res = sexp_make_lit(ctx, sexp_strip_synclos(ctx, sexp_cadr(x))); - break; - case CORE_DEFINE_SYNTAX: - res = analyze_define_syntax(ctx, x); break; - case CORE_LET_SYNTAX: - res = analyze_let_syntax(ctx, x); break; - case CORE_LETREC_SYNTAX: - res = analyze_letrec_syntax(ctx, x); break; - default: - res = sexp_compile_error(ctx, "unknown core form", op); break; - } - } else if (sexp_macrop(op)) { - /* if (in_repl_p) sexp_debug("expand: ", x, ctx); */ - tmp = sexp_cons(ctx, sexp_macro_env(op), SEXP_NULL); - tmp = sexp_cons(ctx, sexp_context_env(ctx), tmp); - tmp = sexp_cons(ctx, x, tmp); - x = apply(sexp_make_child_context(ctx, sexp_context_lambda(ctx)), - sexp_macro_proc(op), - tmp); - /* if (in_repl_p) sexp_debug(" => ", x, ctx); */ - goto loop; - } else if (sexp_opcodep(op)) { - res = sexp_length(ctx, sexp_cdr(x)); - if (sexp_unbox_integer(res) < sexp_opcode_num_args(op)) { - res = sexp_compile_error(ctx, "not enough args for opcode", x); - } else if ((sexp_unbox_integer(res) > sexp_opcode_num_args(op)) - && (! sexp_opcode_variadic_p(op))) { - res = sexp_compile_error(ctx, "too many args for opcode", x); - } else { - res = analyze_app(ctx, sexp_cdr(x)); - analyze_check_exception(res); - sexp_push(ctx, res, op); - } - } else { + if (! cell) { res = analyze_app(ctx, x); + } else { + op = sexp_cdr(cell); + if (sexp_corep(op)) { + switch (sexp_core_code(op)) { + case CORE_DEFINE: + res = analyze_define(ctx, x); break; + case CORE_SET: + res = analyze_set(ctx, x); break; + case CORE_LAMBDA: + res = analyze_lambda(ctx, x); break; + case CORE_IF: + res = analyze_if(ctx, x); break; + case CORE_BEGIN: + res = analyze_seq(ctx, sexp_cdr(x)); break; + case CORE_QUOTE: + res = sexp_make_lit(ctx, sexp_strip_synclos(ctx, sexp_cadr(x))); + break; + case CORE_DEFINE_SYNTAX: + res = analyze_define_syntax(ctx, x); break; + case CORE_LET_SYNTAX: + res = analyze_let_syntax(ctx, x); break; + case CORE_LETREC_SYNTAX: + res = analyze_letrec_syntax(ctx, x); break; + default: + res = sexp_compile_error(ctx, "unknown core form", op); break; + } + } else if (sexp_macrop(op)) { + /* if (in_repl_p) sexp_debug("expand: ", x, ctx); */ + tmp = sexp_cons(ctx, sexp_macro_env(op), SEXP_NULL); + tmp = sexp_cons(ctx, sexp_context_env(ctx), tmp); + tmp = sexp_cons(ctx, x, tmp); + x = apply(sexp_make_child_context(ctx, sexp_context_lambda(ctx)), + sexp_macro_proc(op), + tmp); + /* if (in_repl_p) sexp_debug(" => ", x, ctx); */ + goto loop; + } else if (sexp_opcodep(op)) { + res = sexp_length(ctx, sexp_cdr(x)); + if (sexp_unbox_integer(res) < sexp_opcode_num_args(op)) { + res = sexp_compile_error(ctx, "not enough args for opcode", x); + } else if ((sexp_unbox_integer(res) > sexp_opcode_num_args(op)) + && (! sexp_opcode_variadic_p(op))) { + res = sexp_compile_error(ctx, "too many args for opcode", x); + } else { + res = analyze_app(ctx, sexp_cdr(x)); + analyze_check_exception(res); + sexp_push(ctx, res, op); + } + } else { + res = analyze_app(ctx, x); + } } } else { res = analyze_app(ctx, x); diff --git a/sexp.h b/sexp.h index 65823529..793f5d2c 100644 --- a/sexp.h +++ b/sexp.h @@ -90,6 +90,7 @@ typedef struct sexp_struct *sexp; struct sexp_gc_var_t { sexp *var; + char *name; struct sexp_gc_var_t *next; }; @@ -231,6 +232,7 @@ struct sexp_struct { #define sexp_gc_preserve(ctx, x, y) \ do { \ (y).var = &(x); \ + (y).name = #x; \ (y).next = sexp_context_saves(ctx); \ sexp_context_saves(ctx) = &(y); \ } while (0) From bddbaedfa7cd9fe526bbc5b8e500f38a6fce5cbd Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 13 Jun 2009 21:16:49 +0900 Subject: [PATCH 117/154] test suite now passes with new gc, even starting with a tiny heap and causing multiple allocations. pointer adjusting after a moved realloc still segfaults. --- config.h | 4 +- eval.c | 115 +++++++++++++++++++++------------ gc.c | 192 +++++++++++++++++++++++++++++++++++++++++++++++-------- sexp.c | 22 +++++-- sexp.h | 11 ++-- 5 files changed, 261 insertions(+), 83 deletions(-) diff --git a/config.h b/config.h index 81f1444c..9b2ec71c 100644 --- a/config.h +++ b/config.h @@ -2,8 +2,8 @@ /* Copyright (c) 2009 Alex Shinn. All rights reserved. */ /* BSD-style license: http://synthcode.com/license.txt */ -/* uncomment this to use manual memory management */ -/* #define USE_BOEHM 0 */ +/* uncomment this to use the Boehm conservative GC */ +/* #define USE_BOEHM 1 */ /* uncomment this if you only want fixnum support */ /* #define USE_FLONUMS 0 */ diff --git a/eval.c b/eval.c index bb2517ed..47627c0e 100644 --- a/eval.c +++ b/eval.c @@ -483,7 +483,7 @@ static sexp analyze_lambda (sexp ctx, sexp x) { } analyze_check_exception(value); sexp_push(ctx2, defs, - sexp_make_set(ctx2, analyze_var_ref(ctx, name), value)); + sexp_make_set(ctx2, analyze_var_ref(ctx2, name), value)); } if (sexp_pairp(defs)) { if (! sexp_seqp(body)) { @@ -683,8 +683,13 @@ static sexp analyze (sexp ctx, sexp object) { res = analyze_app(ctx, x); } } - } else { + } else if (sexp_truep(sexp_listp(ctx, sexp_car(x))) + || (sexp_synclop(sexp_car(x)) + && sexp_truep(sexp_listp(ctx, + sexp_synclo_expr(sexp_car(x)))))) { res = analyze_app(ctx, x); + } else { + res = sexp_compile_error(ctx, "invalid operand in application", x); } } else if (sexp_idp(x)) { res = analyze_var_ref(ctx, x); @@ -824,8 +829,11 @@ static void generate_set (sexp ctx, sexp set) { } static void generate_opcode_app (sexp ctx, sexp app) { - sexp ls, op = sexp_car(app); + sexp op = sexp_car(app); sexp_sint_t i, num_args; + sexp_gc_var(ctx, ls, s_ls); + sexp_gc_preserve(ctx, ls, s_ls); + num_args = sexp_unbox_integer(sexp_length(ctx, sexp_cdr(app))); sexp_context_tailp(ctx) = 0; @@ -900,12 +908,14 @@ static void generate_opcode_app (sexp ctx, sexp app) { emit(ctx, sexp_opcode_code(op)); sexp_context_depth(ctx) -= (num_args-1); + sexp_gc_release(ctx, ls, s_ls); } static void generate_general_app (sexp ctx, sexp app) { - sexp ls; sexp_uint_t len = sexp_unbox_integer(sexp_length(ctx, sexp_cdr(app))), tailp = sexp_context_tailp(ctx); + sexp_gc_var(ctx, ls, s_ls); + sexp_gc_preserve(ctx, ls, s_ls); /* push the arguments onto the stack */ sexp_context_tailp(ctx) = 0; @@ -921,6 +931,7 @@ static void generate_general_app (sexp ctx, sexp app) { emit_word(ctx, (sexp_uint_t)sexp_make_integer(len)); sexp_context_depth(ctx) -= len; + sexp_gc_release(ctx, ls, s_ls); } static void generate_app (sexp ctx, sexp app) { @@ -933,8 +944,8 @@ static void generate_app (sexp ctx, sexp app) { static void generate_lambda (sexp ctx, sexp lambda) { sexp ctx2, fv, ls, flags, bc, len, ref, prev_lambda, prev_fv; sexp_uint_t k; - sexp_gc_var(ctx, vec, s_vec); - sexp_gc_preserve(ctx, vec, s_vec); + sexp_gc_var(ctx, tmp, s_tmp); + sexp_gc_preserve(ctx, tmp, s_tmp); prev_lambda = sexp_context_lambda(ctx); prev_fv = sexp_lambdap(prev_lambda) ? sexp_lambda_fv(prev_lambda) : SEXP_NULL; fv = sexp_lambda_fv(lambda); @@ -965,8 +976,10 @@ static void generate_lambda (sexp ctx, sexp lambda) { sexp_bytecode_name(bc) = sexp_lambda_name(lambda); if (sexp_nullp(fv)) { /* shortcut, no free vars */ - vec = sexp_make_vector(ctx2, sexp_make_integer(0), SEXP_VOID); - generate_lit(ctx, sexp_make_procedure(ctx2, flags, len, bc, vec)); + tmp = sexp_make_vector(ctx2, sexp_make_integer(0), SEXP_VOID); + tmp = sexp_make_procedure(ctx2, flags, len, bc, tmp); + sexp_push(ctx, sexp_bytecode_literals(sexp_context_bc(ctx)), tmp); + generate_lit(ctx, tmp); } else { /* push the closed vars */ emit_push(ctx, SEXP_VOID); @@ -990,7 +1003,7 @@ static void generate_lambda (sexp ctx, sexp lambda) { emit_push(ctx, flags); emit(ctx, OP_MAKE_PROCEDURE); } - sexp_gc_release(ctx, vec, s_vec); + sexp_gc_release(ctx, tmp, s_tmp); } static void generate (sexp ctx, sexp x) { @@ -1020,53 +1033,62 @@ static sexp insert_free_var (sexp ctx, sexp x, sexp fv) { } static sexp union_free_vars (sexp ctx, sexp fv1, sexp fv2) { + sexp_gc_var(ctx, res, s_res); + sexp_gc_preserve(ctx, res, s_res); if (sexp_nullp(fv2)) return fv1; - for ( ; sexp_pairp(fv1); fv1=sexp_cdr(fv1)) - fv2 = insert_free_var(ctx, sexp_car(fv1), fv2); - return fv2; + for (res=fv2; sexp_pairp(fv1); fv1=sexp_cdr(fv1)) + res = insert_free_var(ctx, sexp_car(fv1), res); + sexp_gc_release(ctx, res, s_res); + return res; } static sexp diff_free_vars (sexp ctx, sexp lambda, sexp fv, sexp params) { - sexp res = SEXP_NULL; + sexp_gc_var(ctx, res, s_res); + sexp_gc_preserve(ctx, res, s_res); + res = SEXP_NULL; for ( ; sexp_pairp(fv); fv=sexp_cdr(fv)) if ((sexp_ref_loc(sexp_car(fv)) != lambda) || (sexp_memq(NULL, sexp_ref_name(sexp_car(fv)), params) == SEXP_FALSE)) sexp_push(ctx, res, sexp_car(fv)); + sexp_gc_release(ctx, res, s_res); return res; } static sexp free_vars (sexp ctx, sexp x, sexp fv) { - sexp fv1, fv2; + sexp_gc_var(ctx, fv1, s_fv1); + sexp_gc_var(ctx, fv2, s_fv2); + sexp_gc_preserve(ctx, fv1, s_fv1); + sexp_gc_preserve(ctx, fv2, s_fv2); + fv1 = fv; if (sexp_lambdap(x)) { fv1 = free_vars(ctx, sexp_lambda_body(x), SEXP_NULL); - fv2 = diff_free_vars(ctx, x, fv1, - sexp_append2(ctx, - sexp_lambda_locals(x), - sexp_flatten_dot(ctx, - sexp_lambda_params(x)))); + fv2 = sexp_flatten_dot(ctx, sexp_lambda_params(x)); + fv2 = sexp_append2(ctx, sexp_lambda_locals(x), fv2); + fv2 = diff_free_vars(ctx, x, fv1, fv2); sexp_lambda_fv(x) = fv2; - fv = union_free_vars(ctx, fv2, fv); + fv1 = union_free_vars(ctx, fv2, fv); } else if (sexp_pairp(x)) { for ( ; sexp_pairp(x); x=sexp_cdr(x)) - fv = free_vars(ctx, sexp_car(x), fv); + fv1 = free_vars(ctx, sexp_car(x), fv1); } else if (sexp_cndp(x)) { - fv = free_vars(ctx, sexp_cnd_test(x), fv); - fv = free_vars(ctx, sexp_cnd_pass(x), fv); - fv = free_vars(ctx, sexp_cnd_fail(x), fv); + fv1 = free_vars(ctx, sexp_cnd_test(x), fv); + fv1 = free_vars(ctx, sexp_cnd_pass(x), fv1); + fv1 = free_vars(ctx, sexp_cnd_fail(x), fv1); } else if (sexp_seqp(x)) { for (x=sexp_seq_ls(x); sexp_pairp(x); x=sexp_cdr(x)) - fv = free_vars(ctx, sexp_car(x), fv); + fv1 = free_vars(ctx, sexp_car(x), fv1); } else if (sexp_setp(x)) { - fv = free_vars(ctx, sexp_set_value(x), fv); - fv = free_vars(ctx, sexp_set_var(x), fv); + fv1 = free_vars(ctx, sexp_set_value(x), fv); + fv1 = free_vars(ctx, sexp_set_var(x), fv1); } else if (sexp_refp(x) && sexp_lambdap(sexp_ref_loc(x))) { - fv = insert_free_var(ctx, x, fv); + fv1 = insert_free_var(ctx, x, fv); } else if (sexp_synclop(x)) { - fv = free_vars(ctx, sexp_synclo_expr(x), fv); + fv1 = free_vars(ctx, sexp_synclo_expr(x), fv); } - return fv; + sexp_gc_release(ctx, fv1, s_fv1); + return fv1; } static sexp make_param_list(sexp ctx, sexp_uint_t i) { @@ -1084,11 +1106,11 @@ static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i) { sexp_gc_var(ctx, params, s_params); sexp_gc_var(ctx, ref, s_ref); sexp_gc_var(ctx, refs, s_refs); + if (i == sexp_opcode_num_args(op) && sexp_opcode_proc(op)) + return sexp_opcode_proc(op); sexp_gc_preserve(ctx, params, s_params); sexp_gc_preserve(ctx, ref, s_ref); sexp_gc_preserve(ctx, refs, s_refs); - if (i == sexp_opcode_num_args(op) && sexp_opcode_proc(op)) - return sexp_opcode_proc(op); params = make_param_list(ctx, i); lambda = sexp_make_lambda(ctx, params); ctx2 = sexp_make_child_context(ctx, lambda); @@ -1098,7 +1120,9 @@ static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i) { ref = sexp_make_ref(ctx2, sexp_car(ls), env_cell(env, sexp_car(ls))); sexp_push(ctx2, refs, ref); } - generate_opcode_app(ctx2, sexp_cons(ctx2, op, sexp_reverse(ctx2, refs))); + refs = sexp_reverse(ctx2, refs); + refs = sexp_cons(ctx2, op, refs); + generate_opcode_app(ctx2, refs); bc = finalize_bytecode(ctx2); sexp_bytecode_name(bc) = sexp_c_string(ctx2, sexp_opcode_name(op), -1); res = sexp_make_procedure(ctx2, sexp_make_integer(0), sexp_make_integer(i), @@ -1903,6 +1927,18 @@ static struct sexp_struct core_forms[] = { #include "opcodes.c" +static sexp sexp_copy_core (sexp ctx, sexp core) { + sexp res = sexp_alloc_type(ctx, core, SEXP_CORE); + memcpy(res, core, sexp_sizeof(core)); + return res; +} + +static sexp sexp_copy_opcode (sexp ctx, sexp op) { + sexp res = sexp_alloc_type(ctx, opcode, SEXP_OPCODE); + memcpy(res, op, sexp_sizeof(opcode)); + return res; +} + static sexp sexp_make_null_env (sexp ctx, sexp version) { sexp_uint_t i; sexp e = sexp_alloc_type(ctx, env, SEXP_ENV); @@ -1911,16 +1947,10 @@ static sexp sexp_make_null_env (sexp ctx, sexp version) { sexp_env_bindings(e) = SEXP_NULL; for (i=0; i<(sizeof(core_forms)/sizeof(core_forms[0])); i++) env_define(ctx, e, sexp_intern(ctx, sexp_core_name(&core_forms[i])), - &core_forms[i]); + sexp_copy_core(ctx, &core_forms[i])); return e; } -static sexp sexp_copy_opcode (sexp ctx, sexp op) { - sexp res = sexp_alloc_type(ctx, opcode, SEXP_OPCODE); - memcpy(res, op, sexp_sizeof(opcode)); - return res; -} - static sexp sexp_make_standard_env (sexp ctx, sexp version) { sexp_uint_t i; sexp cell, sym; @@ -1930,9 +1960,10 @@ static sexp sexp_make_standard_env (sexp ctx, sexp version) { sexp_gc_preserve(ctx, op, s_op); e = sexp_make_null_env(ctx, version); for (i=0; i<(sizeof(opcodes)/sizeof(opcodes[0])); i++) { - op = &opcodes[i]; + /* op = &opcodes[i]; */ + op = sexp_copy_opcode(ctx, &opcodes[i]); if (sexp_opcode_opt_param_p(op) && sexp_opcode_default(op)) { - op = sexp_copy_opcode(ctx, op); + /* op = sexp_copy_opcode(ctx, op); */ sym = sexp_intern(ctx, (char*)sexp_opcode_default(op)); cell = env_cell_create(ctx, e, sym, SEXP_VOID); sexp_opcode_default(op) = cell; diff --git a/gc.c b/gc.c index 4e5b8c48..88013873 100644 --- a/gc.c +++ b/gc.c @@ -5,7 +5,7 @@ #include "sexp.h" /* #define SEXP_INITIAL_HEAP_SIZE (3*1024*1024) */ -#define SEXP_INITIAL_HEAP_SIZE 40000 +#define SEXP_INITIAL_HEAP_SIZE 37000 #define SEXP_MAXIMUM_HEAP_SIZE 0 #define SEXP_MINIMUM_OBJECT_SIZE (sexp_sizeof(flonum)) @@ -57,6 +57,8 @@ sexp_uint_t sexp_allocated_bytes (sexp x) { res = sexp_type_size_base(t) + len_ptr[0] * sexp_type_size_scale(t); if (res != sexp_allocated_bytes0(x)) { fprintf(stderr, "allocated bytes differ for tag %d @ %p: switch: %lu, data: %lu\n", sexp_pointer_tag(x), x, sexp_allocated_bytes0(x), res); + if (! res) + res = sexp_align(1, 4); /* exit(1); */ } return res; @@ -64,7 +66,7 @@ sexp_uint_t sexp_allocated_bytes (sexp x) { void sexp_mark (sexp x) { sexp *data; - sexp_uint_t i; + sexp_sint_t i; struct sexp_gc_var_t *saves; loop: if (((char*)x < sexp_heap) || ((char*)x >= sexp_heap_end)) { @@ -101,6 +103,7 @@ void sexp_mark (sexp x) { x = sexp_symbol_string(x); goto loop; case SEXP_BYTECODE: + sexp_mark(sexp_bytecode_name(x)); x = sexp_bytecode_literals(x); goto loop; case SEXP_ENV: @@ -124,7 +127,6 @@ void sexp_mark (sexp x) { case SEXP_OPCODE: if (sexp_opcode_proc(x)) sexp_mark(sexp_opcode_proc(x)); if (sexp_opcode_default(x)) sexp_mark(sexp_opcode_default(x)); - if (sexp_opcode_data(x)) sexp_mark(sexp_opcode_data(x)); break; case SEXP_IPORT: case SEXP_OPORT: @@ -136,7 +138,6 @@ void sexp_mark (sexp x) { sexp_mark(sexp_lambda_locals(x)); sexp_mark(sexp_lambda_defs(x)); sexp_mark(sexp_lambda_flags(x)); - sexp_mark(sexp_lambda_body(x)); sexp_mark(sexp_lambda_fv(x)); sexp_mark(sexp_lambda_sv(x)); x = sexp_lambda_body(x); @@ -173,6 +174,128 @@ void sexp_mark (sexp x) { } } +#define sexp_valid_objectp(x) ((! x) || sexp_pointerp(x) || sexp_nullp(x) || sexp_isymbolp(x) || sexp_integerp(x) || (x == SEXP_NULL) || (x == SEXP_FALSE) || (x == SEXP_TRUE) || (x == SEXP_EOF) || (x == SEXP_VOID) || (x == SEXP_UNDEF) || (x == SEXP_CLOSE) || (x == SEXP_RAWDOT) || (sexp_charp(x) && (sexp_unbox_character(x) <= 256)) || (x == SEXP_TRUE) || (x == SEXP_FALSE)) + +#define sexp_verify_one(x, p, t) \ + do { \ + if (((char*)x < sexp_heap) || ((char*)x >= sexp_heap_end)) { \ + if (x && sexp_pointerp(x)) { \ + fprintf(stderr, "outside heap: %p (%x) from: %p %s\n", x, sexp_pointer_tag(x), p, t); \ + return; \ + } \ + } else if (! sexp_valid_objectp(x)) { \ + fprintf(stderr, "bad object: %p from: %p %s\n", x, p, t); \ + } \ + } while (0) + +void sexp_verify (sexp x) { + sexp *data; + sexp_sint_t i; + struct sexp_gc_var_t *saves; + + sexp_verify_one(x, x, "x"); + if ((! x) || (! sexp_pointerp(x))) + return; + switch (sexp_pointer_tag(x)) { + case SEXP_PAIR: + sexp_verify_one(sexp_car(x), x, "car"); + sexp_verify_one(sexp_cdr(x), x, "car"); + break; + case SEXP_STACK: + data = sexp_stack_data(x); + if (! sexp_stack_top(x)) break; + for (i=sexp_stack_top(x)-1; i>=0; i--) + sexp_verify_one(data[i], x, "stack"); + break; + case SEXP_VECTOR: + data = sexp_vector_data(x); + if (! sexp_vector_length(x)) break; + for (i=sexp_vector_length(x)-1; i>=0; i--) + sexp_verify_one(data[i], x, "vector"); + break; + case SEXP_SYMBOL: + sexp_verify_one(sexp_symbol_string(x), x, "symbol_string"); + break; + case SEXP_BYTECODE: + sexp_verify_one(sexp_bytecode_literals(x), x, "bytecode_literals"); + break; + case SEXP_ENV: + sexp_verify_one(sexp_env_lambda(x), x, "env_lambda"); + sexp_verify_one(sexp_env_bindings(x), x, "env_bindings"); + sexp_verify_one(sexp_env_parent(x), x, "env_parent"); + break; + case SEXP_PROCEDURE: + sexp_verify_one(sexp_procedure_code(x), x, "procedure_code"); + sexp_verify_one(sexp_procedure_vars(x), x, "procedure_vars"); + break; + case SEXP_MACRO: + sexp_verify_one(sexp_macro_proc(x), x, "macro_proc"); + sexp_verify_one(sexp_macro_env(x), x, "macro_env"); + break; + case SEXP_SYNCLO: + sexp_verify_one(sexp_synclo_free_vars(x), x, "synclo_free_vars"); + sexp_verify_one(sexp_synclo_expr(x), x, "synclo_expr"); + sexp_verify_one(sexp_synclo_env(x), x, "synclo_env"); + break; + case SEXP_OPCODE: + if (sexp_opcode_proc(x)) + sexp_verify_one(sexp_opcode_proc(x), x, "opcode_proc"); + if (sexp_opcode_default(x)) + sexp_verify_one(sexp_opcode_default(x), x, "opcode_default"); + break; + case SEXP_IPORT: + case SEXP_OPORT: + sexp_verify_one(sexp_port_cookie(x), x, "port_cookie"); + break; + case SEXP_LAMBDA: + sexp_verify_one(sexp_lambda_name(x), x, "lambda_name"); + sexp_verify_one(sexp_lambda_params(x), x, "lambda_params"); + sexp_verify_one(sexp_lambda_locals(x), x, "lambda_locals"); + sexp_verify_one(sexp_lambda_defs(x), x, "lambda_defs"); + sexp_verify_one(sexp_lambda_flags(x), x, "lambda_flags"); + sexp_verify_one(sexp_lambda_body(x), x, "lambda_body"); + sexp_verify_one(sexp_lambda_fv(x), x, "lambda_fv"); + sexp_verify_one(sexp_lambda_sv(x), x, "lambda_sv"); + sexp_verify_one(sexp_lambda_body(x), x, "lambda_body"); + break; + case SEXP_CND: + sexp_verify_one(sexp_cnd_test(x), x, "cnd_test"); + sexp_verify_one(sexp_cnd_fail(x), x, "cnd_fail"); + sexp_verify_one(sexp_cnd_pass(x), x, "cnd_pass"); + break; + case SEXP_SET: + sexp_verify_one(sexp_set_var(x), x, "set_var"); + sexp_verify_one(sexp_set_value(x), x, "set_value"); + break; + case SEXP_REF: + sexp_verify_one(sexp_ref_name(x), x, "ref_name"); + sexp_verify_one(sexp_ref_cell(x), x, "ref_cell"); + break; + case SEXP_SEQ: + sexp_verify_one(sexp_seq_ls(x), x, "seq_ls"); + break; + case SEXP_LIT: + sexp_verify_one(sexp_lit_value(x), x, "lit_value"); + break; + case SEXP_CONTEXT: + sexp_verify_one(sexp_context_env(x), x, "context_env"); + sexp_verify_one(sexp_context_bc(x), x, "context_bc"); + sexp_verify_one(sexp_context_fv(x), x, "context_fv"); + sexp_verify_one(sexp_context_lambda(x), x, "context_lambda"); + sexp_verify_one(sexp_context_parent(x), x, "context_parent"); + for (saves=sexp_context_saves(x); saves; saves=saves->next) + if (saves->var) sexp_verify_one(*(saves->var), x, "context_saves"); + sexp_verify_one(sexp_context_stack(x), x, "context_stack"); + break; + case SEXP_STRING: + case SEXP_FLONUM: + case SEXP_CORE: + break; + default: + fprintf(stderr, "verify: unknown type: %d\n", sexp_pointer_tag(x)); + } +} + #define _adjust(x) if (x && (sexp_pointerp(x)) && (start <= (char*)x) && (((char*)x) <= end)) x = (sexp) (((char*)x)+offset) void sexp_adjust_pointers (sexp x, char* start, char* end, size_t offset) { @@ -457,6 +580,8 @@ void validate_free_list (sexp ctx) { fprintf(stderr, " \x1B[31mfree-list outside heap: %p prev: %p\x1B[0m", p, prev); if (p < prev) fprintf(stderr, " \x1B[31mfree-list out of order at: %p prev: %p cdr: %p\x1B[0m", p, prev, sexp_cdr(p)); + if ((sexp_uint_t)p != sexp_align((sexp_uint_t)p, 4)) + fprintf(stderr, " \x1B[31mfree-list misaligned: %p prev: %p\x1B[0m", p, prev); prev = (sexp) (((char*)p)+(sexp_uint_t)sexp_car(p)); p = sexp_cdr(p); } @@ -471,18 +596,19 @@ void validate_heap (sexp ctx) { /* find the preceding and succeeding free list pointers */ for (r=sexp_cdr(q); r && sexp_pairp(r) && (r= 0x29e00) && ((sexp_uint_t)p <= 0x2a000)) */ + /* fprintf(stderr, "validate heap: %p (%p .. %p)\n", p, q, r); */ size = sexp_align(sexp_allocated_bytes(p), 4); if (sexp_pointer_tag(p) == 0) { fprintf(stderr, "bare object found at %p\n", p); - } else if (sexp_pointer_tag(p) == 0) { - fprintf(stderr, "type object found at %p\n", p); } else if (sexp_pointer_tag(p) > SEXP_CONTEXT) { fprintf(stderr, "bad type at %p: %d\n", p, sexp_pointer_tag(p)); + } else { + sexp_verify(p); } p = (sexp) (((char*)p)+size); } @@ -493,11 +619,14 @@ void validate_gc_vars (sexp ctx) { if (! ctx) return; for (saves=sexp_context_saves(ctx); saves; saves=saves->next) { -/* if (saves->var) { */ -/* if (((char*)*(saves->var) < sexp_heap) */ -/* || ((char*)*(saves->var) >= sexp_heap_end)) */ -/* fprintf(stderr, "bad variable in gc var: %p\n", *(saves->var)); */ -/* } */ + if (saves->var && *(saves->var) && sexp_pointerp(*(saves->var))) { + if (((char*)*(saves->var) < sexp_heap) + || ((char*)*(saves->var) >= sexp_heap_end)) + fprintf(stderr, "bad variable in gc var: %s => %p\n", saves->name, *(saves->var)); + if ((sexp_uint_t)*(saves->var) + != sexp_align((sexp_uint_t)*(saves->var), 4)) + fprintf(stderr, "misaligned gc var: %p\n", *(saves->var)); + } if (prev && (prev > saves)) { fprintf(stderr, "gc vars out of order: %p > %p\n", prev, saves); return; @@ -509,15 +638,18 @@ void validate_gc_vars (sexp ctx) { } } -void validate_freed_pointer (sexp x, sexp *start) { +int validate_freed_pointer (sexp x) { + int freep = 1; sexp *p; - for (p=start; p= size) { if ((sexp_uint_t)sexp_car(ls2) >= (size + SEXP_MINIMUM_OBJECT_SIZE)) { ls3 = (sexp) (((char*)ls2)+size); /* the free tail after ls2 */ @@ -686,7 +824,7 @@ void* sexp_try_alloc (sexp ctx, size_t size) { } else { /* take the whole chunk */ sexp_cdr(ls1) = sexp_cdr(ls2); } - bzero((void*)ls2, size); /* maybe not needed */ + bzero((void*)ls2, size); return ls2; } ls1 = ls2; @@ -697,9 +835,9 @@ void* sexp_try_alloc (sexp ctx, size_t size) { void* sexp_alloc (sexp ctx, size_t size) { void *res; - validate_heap(ctx); - validate_free_list(ctx); - validate_gc_vars(ctx); +/* validate_heap(ctx); */ +/* validate_free_list(ctx); */ +/* validate_gc_vars(ctx); */ size = sexp_align(size, 4); res = sexp_try_alloc(ctx, size); if (! res) { @@ -719,19 +857,19 @@ void* sexp_alloc (sexp ctx, size_t size) { } void sexp_gc_init () { + sexp_uint_t size = sexp_align(SEXP_INITIAL_HEAP_SIZE, 4); sexp next; - sexp_heap = malloc(SEXP_INITIAL_HEAP_SIZE); - sexp_heap_end = sexp_heap + SEXP_INITIAL_HEAP_SIZE; + sexp_heap = malloc(size); + sexp_heap_end = sexp_heap + size; sexp_free_list = (sexp)sexp_heap; next = (sexp) (sexp_heap + sexp_align(sexp_sizeof(pair), 4)); sexp_pointer_tag(sexp_free_list) = SEXP_PAIR; sexp_car(sexp_free_list) = 0; /* actually sexp_sizeof(pair) */ sexp_cdr(sexp_free_list) = next; sexp_pointer_tag(next) = SEXP_PAIR; - sexp_car(next) = (sexp) (SEXP_INITIAL_HEAP_SIZE - - sexp_align(sexp_sizeof(pair), 4)); + sexp_car(next) = (sexp) (size - sexp_align(sexp_sizeof(pair), 4)); sexp_cdr(next) = SEXP_NULL; - stack_base = &next; + stack_base = &next + 32; fprintf(stderr, "heap: %p - %p, next: %p\n", sexp_heap, sexp_heap_end, next); } diff --git a/sexp.c b/sexp.c index 8f7c2f24..60ba2ad8 100644 --- a/sexp.c +++ b/sexp.c @@ -251,7 +251,7 @@ sexp sexp_list2 (sexp ctx, sexp a, sexp b) { sexp sexp_listp (sexp ctx, sexp hare) { sexp turtle; if (! sexp_pairp(hare)) - return sexp_make_boolean(hare == SEXP_NULL); + return sexp_make_boolean(sexp_nullp(hare)); turtle = hare; hare = sexp_cdr(hare); for ( ; sexp_pairp(hare); turtle=sexp_cdr(turtle)) { @@ -259,7 +259,7 @@ sexp sexp_listp (sexp ctx, sexp hare) { hare = sexp_cdr(hare); if (sexp_pairp(hare)) hare = sexp_cdr(hare); } - return sexp_make_boolean(hare == SEXP_NULL); + return sexp_make_boolean(sexp_nullp(hare)); } sexp sexp_memq (sexp ctx, sexp x, sexp ls) { @@ -281,9 +281,11 @@ sexp sexp_assq (sexp ctx, sexp x, sexp ls) { } sexp sexp_reverse (sexp ctx, sexp ls) { - sexp res = SEXP_NULL; - for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) + sexp_gc_var(ctx, res, s_res); + sexp_gc_preserve(ctx, res, s_res); + for (res=SEXP_NULL; sexp_pairp(ls); ls=sexp_cdr(ls)) res = sexp_cons(ctx, sexp_car(ls), res); + sexp_gc_release(ctx, res, s_res); return res; } @@ -306,9 +308,15 @@ sexp sexp_nreverse (sexp ctx, sexp ls) { } sexp sexp_append2 (sexp ctx, sexp a, sexp b) { - for (a=sexp_reverse(ctx, a); sexp_pairp(a); a=sexp_cdr(a)) - b = sexp_cons(ctx, sexp_car(a), b); - return b; + sexp_gc_var(ctx, a1, s_a1); + sexp_gc_var(ctx, b1, s_b1); + sexp_gc_preserve(ctx, a1, s_a1); + sexp_gc_preserve(ctx, b1, s_b1); + b1 = b; + for (a1=sexp_reverse(ctx, a); sexp_pairp(a1); a1=sexp_cdr(a1)) + b1 = sexp_cons(ctx, sexp_car(a1), b1); + sexp_gc_release(ctx, a1, s_a1); + return b1; } sexp sexp_length (sexp ctx, sexp ls) { diff --git a/sexp.h b/sexp.h index 793f5d2c..fc25b43e 100644 --- a/sexp.h +++ b/sexp.h @@ -65,7 +65,6 @@ enum sexp_types { SEXP_IPORT, SEXP_OPORT, SEXP_EXCEPTION, - /* the following are used only by the evaluator */ SEXP_PROCEDURE, SEXP_MACRO, SEXP_SYNCLO, @@ -201,10 +200,10 @@ struct sexp_struct { #define SEXP_MAKE_IMMEDIATE(n) ((sexp) ((n< Date: Sun, 14 Jun 2009 23:41:00 +0900 Subject: [PATCH 118/154] fixing some gc var preservation bugs --- eval.c | 69 ++++++++++++++++++++++++++++++++++++++-------------------- gc.c | 34 +++++++++++++++++++++++++---- main.c | 8 ++++--- sexp.c | 9 +++----- 4 files changed, 84 insertions(+), 36 deletions(-) diff --git a/eval.c b/eval.c index 47627c0e..b7a8fe1b 100644 --- a/eval.c +++ b/eval.c @@ -264,7 +264,7 @@ static sexp sexp_make_context(sexp ctx, sexp stack, sexp env) { sexp_bytecode_name(sexp_context_bc(res)) = SEXP_FALSE; sexp_bytecode_length(sexp_context_bc(res)) = INIT_BCODE_SIZE; sexp_bytecode_literals(sexp_context_bc(res)) = SEXP_NULL; - sexp_context_parent(res) = SEXP_FALSE; + sexp_context_parent(res) = ctx; sexp_context_lambda(res) = SEXP_FALSE; sexp_context_fv(res) = SEXP_NULL; sexp_context_saves(res) = 0; @@ -343,11 +343,12 @@ static sexp sexp_identifier_eq(sexp ctx, sexp e1, sexp id1, sexp e2, sexp id2) { static sexp sexp_compile_error(sexp ctx, char *message, sexp obj) { sexp exn; sexp_gc_var(ctx, irritants, s_irr); + sexp_gc_var(ctx, msg, s_msg); sexp_gc_preserve(ctx, irritants, s_irr); + sexp_gc_preserve(ctx, msg, s_msg); irritants = sexp_list1(ctx, obj); - exn = sexp_make_exception(ctx, the_compile_error_symbol, - sexp_c_string(ctx, message, -1), - irritants, + msg = sexp_c_string(ctx, message, -1); + exn = sexp_make_exception(ctx, the_compile_error_symbol, msg, irritants, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE); sexp_gc_release(ctx, irritants, s_irr); return exn; @@ -919,8 +920,7 @@ static void generate_general_app (sexp ctx, sexp app) { /* push the arguments onto the stack */ sexp_context_tailp(ctx) = 0; - for (ls = sexp_reverse(ctx, sexp_cdr(app)); sexp_pairp(ls); - ls = sexp_cdr(ls)) + for (ls=sexp_reverse(ctx, sexp_cdr(app)); sexp_pairp(ls); ls=sexp_cdr(ls)) generate(ctx, sexp_car(ls)); /* push the operator onto the stack */ @@ -942,10 +942,12 @@ static void generate_app (sexp ctx, sexp app) { } static void generate_lambda (sexp ctx, sexp lambda) { - sexp ctx2, fv, ls, flags, bc, len, ref, prev_lambda, prev_fv; + sexp ctx2, fv, ls, flags, len, ref, prev_lambda, prev_fv; sexp_uint_t k; sexp_gc_var(ctx, tmp, s_tmp); + sexp_gc_var(ctx, bc, s_bc); sexp_gc_preserve(ctx, tmp, s_tmp); + sexp_gc_preserve(ctx, bc, s_bc); prev_lambda = sexp_context_lambda(ctx); prev_fv = sexp_lambdap(prev_lambda) ? sexp_lambda_fv(prev_lambda) : SEXP_NULL; fv = sexp_lambda_fv(lambda); @@ -969,9 +971,9 @@ static void generate_lambda (sexp ctx, sexp lambda) { } sexp_context_tailp(ctx2) = 1; generate(ctx2, sexp_lambda_body(lambda)); - flags = sexp_make_integer((sexp_listp(ctx, sexp_lambda_params(lambda)) + flags = sexp_make_integer((sexp_listp(ctx2, sexp_lambda_params(lambda)) == SEXP_FALSE) ? 1 : 0); - len = sexp_length(ctx, sexp_lambda_params(lambda)); + len = sexp_length(ctx2, sexp_lambda_params(lambda)); bc = finalize_bytecode(ctx2); sexp_bytecode_name(bc) = sexp_lambda_name(lambda); if (sexp_nullp(fv)) { @@ -1034,9 +1036,9 @@ static sexp insert_free_var (sexp ctx, sexp x, sexp fv) { static sexp union_free_vars (sexp ctx, sexp fv1, sexp fv2) { sexp_gc_var(ctx, res, s_res); - sexp_gc_preserve(ctx, res, s_res); if (sexp_nullp(fv2)) return fv1; + sexp_gc_preserve(ctx, res, s_res); for (res=fv2; sexp_pairp(fv1); fv1=sexp_cdr(fv1)) res = insert_free_var(ctx, sexp_car(fv1), res); sexp_gc_release(ctx, res, s_res); @@ -1107,7 +1109,7 @@ static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i) { sexp_gc_var(ctx, ref, s_ref); sexp_gc_var(ctx, refs, s_refs); if (i == sexp_opcode_num_args(op) && sexp_opcode_proc(op)) - return sexp_opcode_proc(op); + return sexp_opcode_proc(op); /* return before preserving */ sexp_gc_preserve(ctx, params, s_params); sexp_gc_preserve(ctx, ref, s_ref); sexp_gc_preserve(ctx, refs, s_refs); @@ -1176,7 +1178,7 @@ static sexp_uint_t sexp_restore_stack(sexp saved, sexp *current) { goto call_error_handler;} \ while (0) -sexp vm (sexp proc, sexp ctx) { +sexp vm (sexp ctx, sexp proc) { sexp bc = sexp_procedure_code(proc), cp = sexp_procedure_vars(proc); sexp env = sexp_context_env(ctx), *stack = sexp_stack_data(sexp_context_stack(ctx)); @@ -1199,6 +1201,7 @@ sexp vm (sexp proc, sexp ctx) { fprintf(stderr, "%s\n", (*ip<=71)?reverse_opcode_names[*ip]:"UNKNOWN"); } #endif + sexp_context_top(ctx) = top; /* debugging */ switch (*ip++) { case OP_NOOP: break; @@ -1324,40 +1327,47 @@ sexp vm (sexp proc, sexp ctx) { fp = top-4; break; case OP_FCALL0: + sexp_context_top(ctx) = top; _PUSH(((sexp_proc1)_UWORD0)(ctx)); ip += sizeof(sexp); sexp_check_exception(); break; case OP_FCALL1: + sexp_context_top(ctx) = top; _ARG1 = ((sexp_proc2)_UWORD0)(ctx, _ARG1); ip += sizeof(sexp); sexp_check_exception(); break; case OP_FCALL2: + sexp_context_top(ctx) = top; _ARG2 = ((sexp_proc3)_UWORD0)(ctx, _ARG1, _ARG2); top--; ip += sizeof(sexp); sexp_check_exception(); break; case OP_FCALL3: + sexp_context_top(ctx) = top; _ARG3 =((sexp_proc4)_UWORD0)(ctx, _ARG1, _ARG2, _ARG3); top -= 2; ip += sizeof(sexp); sexp_check_exception(); break; case OP_FCALL4: + sexp_context_top(ctx) = top; _ARG4 =((sexp_proc5)_UWORD0)(ctx, _ARG1, _ARG2, _ARG3, _ARG4); top -= 3; ip += sizeof(sexp); sexp_check_exception(); break; case OP_FCALL5: + sexp_context_top(ctx) = top; _ARG5 =((sexp_proc6)_UWORD0)(ctx, _ARG1, _ARG2, _ARG3, _ARG4, _ARG5); top -= 4; ip += sizeof(sexp); sexp_check_exception(); break; case OP_FCALL6: + sexp_context_top(ctx) = top; _ARG6 =((sexp_proc7)_UWORD0)(ctx, _ARG1, _ARG2, _ARG3, _ARG4, _ARG5, _ARG6); top -= 5; ip += sizeof(sexp); @@ -1440,10 +1450,12 @@ sexp vm (sexp proc, sexp ctx) { _ARG1 = sexp_make_integer(sexp_string_length(_ARG1)); break; case OP_MAKE_PROCEDURE: + sexp_context_top(ctx) = top; _ARG4 = sexp_make_procedure(ctx, _ARG1, _ARG2, _ARG3, _ARG4); top-=3; break; case OP_MAKE_VECTOR: + sexp_context_top(ctx) = top; _ARG2 = sexp_make_vector(ctx, _ARG1, _ARG2); top--; break; @@ -1702,6 +1714,7 @@ sexp vm (sexp proc, sexp ctx) { _ARG1 = SEXP_VOID; break; case OP_READ: + sexp_context_top(ctx) = top; _ARG1 = sexp_read(ctx, _ARG1); sexp_check_exception(); break; @@ -1791,12 +1804,12 @@ sexp sexp_load (sexp ctx, sexp source, sexp env) { sexp_gc_preserve(ctx, ctx2, s_ctx2); sexp_gc_preserve(ctx, x, s_x); sexp_gc_preserve(ctx, in, s_in); + in = sexp_open_input_file(ctx, source); + out = env_global_ref(env, the_cur_err_symbol, SEXP_FALSE); ctx2 = sexp_make_context(ctx, NULL, env); sexp_context_parent(ctx2) = ctx; - out = env_global_ref(env, the_cur_err_symbol, SEXP_FALSE); tmp = sexp_env_bindings(env); sexp_context_tailp(ctx2) = 0; - in = sexp_open_input_file(ctx, source); if (sexp_exceptionp(in)) { sexp_print_exception(ctx, in, out); res = in; @@ -1995,37 +2008,47 @@ sexp apply (sexp ctx, sexp proc, sexp args) { stack[top++] = sexp_make_integer(sexp_bytecode_data(final_resumer)); stack[top++] = sexp_make_vector(ctx, 0, SEXP_VOID); stack[top++] = sexp_make_integer(0); - return vm(proc, ctx); + return vm(ctx, proc); } sexp compile (sexp ctx, sexp x) { - sexp res; sexp_gc_var(ctx, ast, s_ast); sexp_gc_var(ctx, ctx2, s_ctx2); + sexp_gc_var(ctx, vec, s_vec); + sexp_gc_var(ctx, res, s_res); sexp_gc_preserve(ctx, ast, s_ast); sexp_gc_preserve(ctx, ctx2, s_ctx2); + sexp_gc_preserve(ctx, vec, s_vec); + sexp_gc_preserve(ctx, res, s_res); analyze_bind(ast, x, ctx); free_vars(ctx, ast, SEXP_NULL); /* should return SEXP_NULL */ ctx2 = sexp_make_context(ctx, sexp_context_stack(ctx), sexp_context_env(ctx)); + sexp_context_parent(ctx2) = ctx; generate(ctx2, ast); - res = sexp_make_procedure(ctx, sexp_make_integer(0), - sexp_make_integer(0), - finalize_bytecode(ctx2), - sexp_make_vector(ctx, 0, SEXP_VOID)); + res = finalize_bytecode(ctx2); + vec = sexp_make_vector(ctx, 0, SEXP_VOID); + res = sexp_make_procedure(ctx, sexp_make_integer(0), sexp_make_integer(0), + res, vec); sexp_gc_release(ctx, ast, s_ast); return res; } sexp eval_in_context (sexp ctx, sexp obj) { - sexp thunk = compile(ctx, obj); + sexp res; + sexp_gc_var(ctx, thunk, s_thunk); + sexp_gc_preserve(ctx, thunk, s_thunk); + thunk = compile(ctx, obj); if (sexp_exceptionp(thunk)) { sexp_print_exception(ctx, thunk, env_global_ref(sexp_context_env(ctx), the_cur_err_symbol, SEXP_FALSE)); - return thunk; + res = thunk; + } else { + res = apply(ctx, thunk, SEXP_NULL); } - return apply(ctx, thunk, SEXP_NULL); + sexp_gc_release(ctx, thunk, s_thunk); + return res; } sexp eval (sexp obj, sexp env) { diff --git a/gc.c b/gc.c index 88013873..66a3730c 100644 --- a/gc.c +++ b/gc.c @@ -638,17 +638,42 @@ void validate_gc_vars (sexp ctx) { } } -int validate_freed_pointer (sexp x) { +int validate_freed_pointer (sexp ctx, sexp x) { int freep = 1; sexp *p; + struct sexp_gc_var_t *saves, *prev=NULL; + char *v1, *v2; + for (p=&x; pnext) { + if (saves->var && prev && prev->var + && (((saves->var <= p) && (prev->var >= p)) + || ((saves->var >= p) && (prev->var <= p)))) { + v1 = saves->name; + v2 = prev->name; + break; + } + prev = saves; + } + if (v1 && v2) + fprintf(stderr, "reference to freed var %p at %p between %s and %s: ", + x, p, v1, v2); + else if (sexp_context_saves(ctx) && (p <= sexp_context_saves(ctx)->var)) + fprintf(stderr, "reference to freed var %p at %p after %s: ", + x, p, sexp_context_saves(ctx)->name); + else if (prev && (p >= prev->var)) + fprintf(stderr, "reference to freed var %p at %p before %s: ", + x, p, prev->name); + else + fprintf(stderr, "reference to freed var %p at %p: ", x, p); simple_write(x, 1, stderr); putc('\n', stderr); freep = 0; } } + return freep; } @@ -669,7 +694,7 @@ sexp sexp_sweep (sexp ctx) { fprintf(stderr, "sweep: p: %p <= q: %p\n", p, q); } size = sexp_align(sexp_allocated_bytes(p), 4); - if ((! sexp_gc_mark(p)) && validate_freed_pointer(p)) { + if ((! sexp_gc_mark(p))/* && validate_freed_pointer(ctx, p) */) { /* fprintf(stderr, "\x1B[31mfreeing %lu bytes @ %p (%x) ", size, p, sexp_pointer_tag(p)); */ /* simple_write(p, 1, stderr); */ /* fprintf(stderr, "\x1B[0m\n"); */ @@ -870,6 +895,7 @@ void sexp_gc_init () { sexp_car(next) = (sexp) (size - sexp_align(sexp_sizeof(pair), 4)); sexp_cdr(next) = SEXP_NULL; stack_base = &next + 32; - fprintf(stderr, "heap: %p - %p, next: %p\n", sexp_heap, sexp_heap_end, next); + fprintf(stderr, "heap: %p - %p, next: %p, stack_base: %p\n", + sexp_heap, sexp_heap_end, next, stack_base); } diff --git a/main.c b/main.c index a9d12e04..0061dffd 100644 --- a/main.c +++ b/main.c @@ -2,7 +2,9 @@ #include "eval.c" void repl (sexp ctx) { - sexp obj, tmp, res, env, in, out, err; + sexp tmp, res, env, in, out, err; + sexp_gc_var(ctx, obj, s_obj); + sexp_gc_preserve(ctx, obj, s_obj); env = sexp_context_env(ctx); sexp_context_tracep(ctx) = 1; in = env_global_ref(env, the_cur_in_symbol, SEXP_FALSE); @@ -29,6 +31,7 @@ void repl (sexp ctx) { } } } + sexp_gc_release(ctx, obj, s_obj); } void run_main (int argc, char **argv) { @@ -36,12 +39,11 @@ void run_main (int argc, char **argv) { sexp_uint_t i, quit=0, init_loaded=0; ctx = sexp_make_context(NULL, NULL, NULL); - env = sexp_make_standard_env(ctx, sexp_make_integer(5)); + env = sexp_context_env(ctx); env_define(ctx, env, the_interaction_env_symbol, env); out = env_global_ref(env, the_cur_out_symbol, SEXP_FALSE); err_cell = env_cell(env, the_cur_err_symbol); perr_cell = env_cell(env, sexp_intern(ctx, "print-exception")); - sexp_context_env(ctx) = env; sexp_context_tailp(ctx) = 0; if (err_cell && perr_cell && sexp_opcodep(sexp_cdr(perr_cell))) { emit(ctx, OP_GLOBAL_KNOWN_REF); diff --git a/sexp.c b/sexp.c index 60ba2ad8..72f5e503 100644 --- a/sexp.c +++ b/sexp.c @@ -49,10 +49,7 @@ sexp sexp_symbol_table[SEXP_SYMBOL_TABLE_SIZE]; sexp sexp_alloc_tagged(sexp ctx, size_t size, sexp_uint_t tag) { sexp res = (sexp) sexp_alloc(ctx, size); - if (! res) - errx(EX_OSERR, "out of memory: couldn't allocate %ld bytes for %ld", - size ,tag); - sexp_pointer_tag(res) = tag; + if (res) sexp_pointer_tag(res) = tag; return res; } @@ -482,8 +479,8 @@ sexp sexp_make_vector(sexp ctx, sexp len, sexp dflt) { sexp v, *x; int i, clen = sexp_unbox_integer(len); if (! clen) return the_empty_vector; - v = sexp_alloc(ctx, sexp_sizeof(vector) + clen*sizeof(sexp)); - sexp_pointer_tag(v) = SEXP_VECTOR; + v = sexp_alloc_tagged(ctx, sexp_sizeof(vector) + clen*sizeof(sexp), + SEXP_VECTOR); x = sexp_vector_data(v); for (i=0; i Date: Sun, 14 Jun 2009 23:49:39 +0900 Subject: [PATCH 119/154] preserving file names during load in main --- main.c | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) diff --git a/main.c b/main.c index 0061dffd..66a6b85b 100644 --- a/main.c +++ b/main.c @@ -37,8 +37,10 @@ void repl (sexp ctx) { void run_main (int argc, char **argv) { sexp env, out=NULL, res, ctx, perr_cell, err_cell, err_handler; sexp_uint_t i, quit=0, init_loaded=0; + sexp_gc_var(ctx, str, s_str); ctx = sexp_make_context(NULL, NULL, NULL); + sexp_gc_preserve(ctx, str, s_str); env = sexp_context_env(ctx); env_define(ctx, env, the_interaction_env_symbol, env); out = env_global_ref(env, the_cur_out_symbol, SEXP_FALSE); @@ -69,7 +71,7 @@ void run_main (int argc, char **argv) { case 'e': case 'p': if (! init_loaded++) - sexp_load(ctx, sexp_c_string(ctx, sexp_init_file, -1), env); + sexp_load(ctx, str=sexp_c_string(ctx, sexp_init_file, -1), env); res = sexp_read_from_string(ctx, argv[i+1]); if (! sexp_exceptionp(res)) res = eval_in_context(ctx, res); @@ -85,8 +87,8 @@ void run_main (int argc, char **argv) { #endif case 'l': if (! init_loaded++) - sexp_load(ctx, sexp_c_string(ctx, sexp_init_file, -1), env); - sexp_load(ctx, sexp_c_string(ctx, argv[++i], -1), env); + sexp_load(ctx, str=sexp_c_string(ctx, sexp_init_file, -1), env); + sexp_load(ctx, str=sexp_c_string(ctx, argv[++i], -1), env); break; case 'q': init_loaded = 1; @@ -98,13 +100,15 @@ void run_main (int argc, char **argv) { if (! quit) { if (! init_loaded) - sexp_load(ctx, sexp_c_string(ctx, sexp_init_file, -1), env); + sexp_load(ctx, str=sexp_c_string(ctx, sexp_init_file, -1), env); if (i < argc) for ( ; i < argc; i++) - sexp_load(ctx, sexp_c_string(ctx, argv[i], -1), env); + sexp_load(ctx, str=sexp_c_string(ctx, argv[i], -1), env); else repl(ctx); } + + sexp_gc_release(ctx, str, s_str); } int main (int argc, char **argv) { From c725c48f74bb9cccffebe70994f6991cf01ce07c Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 15 Jun 2009 17:34:26 +0900 Subject: [PATCH 120/154] switching to data-driven sexp_mark --- Makefile | 5 +- VERSION | 2 +- gc.c | 273 +++--------------------------------------------------- opcodes.c | 2 +- sexp.c | 63 +++++++------ sexp.h | 10 +- 6 files changed, 56 insertions(+), 299 deletions(-) diff --git a/Makefile b/Makefile index 32b994e6..cc7450df 100644 --- a/Makefile +++ b/Makefile @@ -14,9 +14,6 @@ LDFLAGS=-lm # -Oz for smaller size on darwin CFLAGS=-Wall -g -save-temps -#GC_OBJ=./gc/gc.a -GC_OBJ= - ./gc/gc.a: ./gc/alloc.c cd gc && make @@ -29,7 +26,7 @@ eval.o: eval.c debug.c opcodes.c eval.h sexp.h config.h defaults.h Makefile main.o: main.c eval.c debug.c opcodes.c eval.h sexp.h config.h defaults.h Makefile gcc -c $(CPPFLAGS) $(CFLAGS) -o $@ $< -chibi-scheme: main.o sexp.o $(GC_OBJ) +chibi-scheme: main.o sexp.o gcc $(CFLAGS) $(LDFLAGS) -o $@ $^ clean: diff --git a/VERSION b/VERSION index 49d59571..3b04cfb6 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.1 +0.2 diff --git a/gc.c b/gc.c index 66a3730c..3ab32086 100644 --- a/gc.c +++ b/gc.c @@ -15,38 +15,6 @@ static sexp sexp_free_list; static sexp* stack_base; -sexp_uint_t sexp_allocated_bytes0 (sexp x) { - switch (sexp_pointer_tag(x)) { - case SEXP_PAIR: return sexp_sizeof(pair); - case SEXP_SYMBOL: return sexp_sizeof(symbol); - case SEXP_STRING: return sexp_sizeof(string)+sexp_string_length(x)+1; - case SEXP_VECTOR: - return sexp_sizeof(vector)+(sexp_vector_length(x)*sizeof(sexp)); - case SEXP_STACK: - return sexp_sizeof(stack)+(sexp_stack_length(x)*sizeof(sexp)); - case SEXP_FLONUM: return sexp_sizeof(flonum); - case SEXP_BIGNUM: return sexp_sizeof(bignum); - case SEXP_IPORT: - case SEXP_OPORT: return sexp_sizeof(port); - case SEXP_EXCEPTION: return sexp_sizeof(exception); - case SEXP_PROCEDURE: return sexp_sizeof(procedure); - case SEXP_MACRO: return sexp_sizeof(macro); - case SEXP_SYNCLO: return sexp_sizeof(synclo); - case SEXP_ENV: return sexp_sizeof(env); - case SEXP_BYTECODE: return sexp_sizeof(bytecode)+sexp_bytecode_length(x); - case SEXP_CORE: return sexp_sizeof(core); - case SEXP_OPCODE: return sexp_sizeof(opcode); - case SEXP_LAMBDA: return sexp_sizeof(lambda); - case SEXP_CND: return sexp_sizeof(cnd); - case SEXP_REF: return sexp_sizeof(ref); - case SEXP_SET: return sexp_sizeof(set); - case SEXP_SEQ: return sexp_sizeof(seq); - case SEXP_LIT: return sexp_sizeof(lit); - case SEXP_CONTEXT: return sexp_sizeof(context); - default: return sexp_align(1, 4); - } -} - sexp_uint_t sexp_allocated_bytes (sexp x) { sexp_uint_t res, *len_ptr; sexp t; @@ -55,247 +23,34 @@ sexp_uint_t sexp_allocated_bytes (sexp x) { t = &(sexp_types[sexp_pointer_tag(x)]); len_ptr = (sexp_uint_t*) (((char*)x) + sexp_type_size_off(t)); res = sexp_type_size_base(t) + len_ptr[0] * sexp_type_size_scale(t); - if (res != sexp_allocated_bytes0(x)) { - fprintf(stderr, "allocated bytes differ for tag %d @ %p: switch: %lu, data: %lu\n", sexp_pointer_tag(x), x, sexp_allocated_bytes0(x), res); - if (! res) - res = sexp_align(1, 4); - /* exit(1); */ - } return res; } void sexp_mark (sexp x) { - sexp *data; - sexp_sint_t i; + sexp_uint_t *len_ptr; + sexp_sint_t i, len; + sexp t, *p; struct sexp_gc_var_t *saves; loop: - if (((char*)x < sexp_heap) || ((char*)x >= sexp_heap_end)) { - if (x && sexp_pointerp(x) && (sexp_pointer_tag(x) != SEXP_OPCODE) - && (sexp_pointer_tag(x) != SEXP_CORE)) - fprintf(stderr, "--------------- outside heap: %p (%x) ------------------\n", x, sexp_pointer_tag(x)); - return; - } if ((! x) || (! sexp_pointerp(x)) || sexp_gc_mark(x)) return; sexp_gc_mark(x) = 1; -/* fprintf(stderr, "----------------- marking %p (%x) --------------------\n", */ -/* x, sexp_pointer_tag(x)); */ - switch (sexp_pointer_tag(x)) { - case SEXP_PAIR: - sexp_mark(sexp_car(x)); - x = sexp_cdr(x); - goto loop; - case SEXP_STACK: - data = sexp_stack_data(x); - if (! sexp_stack_top(x)) break; - for (i=sexp_stack_top(x)-1; i>0; i--) - sexp_mark(data[i]); - x = data[0]; - goto loop; - case SEXP_VECTOR: - data = sexp_vector_data(x); - if (! sexp_vector_length(x)) break; - for (i=sexp_vector_length(x)-1; i>0; i--) - sexp_mark(data[i]); - x = data[0]; - goto loop; - case SEXP_SYMBOL: - x = sexp_symbol_string(x); - goto loop; - case SEXP_BYTECODE: - sexp_mark(sexp_bytecode_name(x)); - x = sexp_bytecode_literals(x); - goto loop; - case SEXP_ENV: - sexp_mark(sexp_env_lambda(x)); - sexp_mark(sexp_env_bindings(x)); - x = sexp_env_parent(x); - if (x) goto loop; else break; - case SEXP_PROCEDURE: - sexp_mark(sexp_procedure_code(x)); - x = sexp_procedure_vars(x); - goto loop; - case SEXP_MACRO: - sexp_mark(sexp_macro_proc(x)); - x = sexp_macro_env(x); - goto loop; - case SEXP_SYNCLO: - sexp_mark(sexp_synclo_free_vars(x)); - sexp_mark(sexp_synclo_expr(x)); - x = sexp_synclo_env(x); - goto loop; - case SEXP_OPCODE: - if (sexp_opcode_proc(x)) sexp_mark(sexp_opcode_proc(x)); - if (sexp_opcode_default(x)) sexp_mark(sexp_opcode_default(x)); - break; - case SEXP_IPORT: - case SEXP_OPORT: - x = sexp_port_cookie(x); - if (x) goto loop; else break; - case SEXP_LAMBDA: - sexp_mark(sexp_lambda_name(x)); - sexp_mark(sexp_lambda_params(x)); - sexp_mark(sexp_lambda_locals(x)); - sexp_mark(sexp_lambda_defs(x)); - sexp_mark(sexp_lambda_flags(x)); - sexp_mark(sexp_lambda_fv(x)); - sexp_mark(sexp_lambda_sv(x)); - x = sexp_lambda_body(x); - goto loop; - case SEXP_CND: - sexp_mark(sexp_cnd_test(x)); - sexp_mark(sexp_cnd_fail(x)); - x = sexp_cnd_pass(x); - goto loop; - case SEXP_SET: - sexp_mark(sexp_set_var(x)); - x = sexp_set_value(x); - goto loop; - case SEXP_REF: - sexp_mark(sexp_ref_name(x)); - x = sexp_ref_cell(x); - goto loop; - case SEXP_SEQ: - x = sexp_seq_ls(x); - goto loop; - case SEXP_LIT: - x = sexp_lit_value(x); - goto loop; - case SEXP_CONTEXT: - sexp_mark(sexp_context_env(x)); - sexp_mark(sexp_context_bc(x)); - sexp_mark(sexp_context_fv(x)); - sexp_mark(sexp_context_lambda(x)); - sexp_mark(sexp_context_parent(x)); + if (sexp_contextp(x)) for (saves=sexp_context_saves(x); saves; saves=saves->next) if (saves->var) sexp_mark(*(saves->var)); - x = sexp_context_stack(x); + t = &(sexp_types[sexp_pointer_tag(x)]); + p = (sexp*) (((char*)x) + sexp_type_field_base(t)); + len_ptr = (sexp_uint_t*) (((char*)x) + sexp_type_field_len_off(t)); + len = sexp_type_field_len_base(t) + + len_ptr[0]*sexp_type_field_len_scale(t) - 1; + if (len >= 0) { + for (i=0; i= sexp_heap_end)) { \ - if (x && sexp_pointerp(x)) { \ - fprintf(stderr, "outside heap: %p (%x) from: %p %s\n", x, sexp_pointer_tag(x), p, t); \ - return; \ - } \ - } else if (! sexp_valid_objectp(x)) { \ - fprintf(stderr, "bad object: %p from: %p %s\n", x, p, t); \ - } \ - } while (0) - -void sexp_verify (sexp x) { - sexp *data; - sexp_sint_t i; - struct sexp_gc_var_t *saves; - - sexp_verify_one(x, x, "x"); - if ((! x) || (! sexp_pointerp(x))) - return; - switch (sexp_pointer_tag(x)) { - case SEXP_PAIR: - sexp_verify_one(sexp_car(x), x, "car"); - sexp_verify_one(sexp_cdr(x), x, "car"); - break; - case SEXP_STACK: - data = sexp_stack_data(x); - if (! sexp_stack_top(x)) break; - for (i=sexp_stack_top(x)-1; i>=0; i--) - sexp_verify_one(data[i], x, "stack"); - break; - case SEXP_VECTOR: - data = sexp_vector_data(x); - if (! sexp_vector_length(x)) break; - for (i=sexp_vector_length(x)-1; i>=0; i--) - sexp_verify_one(data[i], x, "vector"); - break; - case SEXP_SYMBOL: - sexp_verify_one(sexp_symbol_string(x), x, "symbol_string"); - break; - case SEXP_BYTECODE: - sexp_verify_one(sexp_bytecode_literals(x), x, "bytecode_literals"); - break; - case SEXP_ENV: - sexp_verify_one(sexp_env_lambda(x), x, "env_lambda"); - sexp_verify_one(sexp_env_bindings(x), x, "env_bindings"); - sexp_verify_one(sexp_env_parent(x), x, "env_parent"); - break; - case SEXP_PROCEDURE: - sexp_verify_one(sexp_procedure_code(x), x, "procedure_code"); - sexp_verify_one(sexp_procedure_vars(x), x, "procedure_vars"); - break; - case SEXP_MACRO: - sexp_verify_one(sexp_macro_proc(x), x, "macro_proc"); - sexp_verify_one(sexp_macro_env(x), x, "macro_env"); - break; - case SEXP_SYNCLO: - sexp_verify_one(sexp_synclo_free_vars(x), x, "synclo_free_vars"); - sexp_verify_one(sexp_synclo_expr(x), x, "synclo_expr"); - sexp_verify_one(sexp_synclo_env(x), x, "synclo_env"); - break; - case SEXP_OPCODE: - if (sexp_opcode_proc(x)) - sexp_verify_one(sexp_opcode_proc(x), x, "opcode_proc"); - if (sexp_opcode_default(x)) - sexp_verify_one(sexp_opcode_default(x), x, "opcode_default"); - break; - case SEXP_IPORT: - case SEXP_OPORT: - sexp_verify_one(sexp_port_cookie(x), x, "port_cookie"); - break; - case SEXP_LAMBDA: - sexp_verify_one(sexp_lambda_name(x), x, "lambda_name"); - sexp_verify_one(sexp_lambda_params(x), x, "lambda_params"); - sexp_verify_one(sexp_lambda_locals(x), x, "lambda_locals"); - sexp_verify_one(sexp_lambda_defs(x), x, "lambda_defs"); - sexp_verify_one(sexp_lambda_flags(x), x, "lambda_flags"); - sexp_verify_one(sexp_lambda_body(x), x, "lambda_body"); - sexp_verify_one(sexp_lambda_fv(x), x, "lambda_fv"); - sexp_verify_one(sexp_lambda_sv(x), x, "lambda_sv"); - sexp_verify_one(sexp_lambda_body(x), x, "lambda_body"); - break; - case SEXP_CND: - sexp_verify_one(sexp_cnd_test(x), x, "cnd_test"); - sexp_verify_one(sexp_cnd_fail(x), x, "cnd_fail"); - sexp_verify_one(sexp_cnd_pass(x), x, "cnd_pass"); - break; - case SEXP_SET: - sexp_verify_one(sexp_set_var(x), x, "set_var"); - sexp_verify_one(sexp_set_value(x), x, "set_value"); - break; - case SEXP_REF: - sexp_verify_one(sexp_ref_name(x), x, "ref_name"); - sexp_verify_one(sexp_ref_cell(x), x, "ref_cell"); - break; - case SEXP_SEQ: - sexp_verify_one(sexp_seq_ls(x), x, "seq_ls"); - break; - case SEXP_LIT: - sexp_verify_one(sexp_lit_value(x), x, "lit_value"); - break; - case SEXP_CONTEXT: - sexp_verify_one(sexp_context_env(x), x, "context_env"); - sexp_verify_one(sexp_context_bc(x), x, "context_bc"); - sexp_verify_one(sexp_context_fv(x), x, "context_fv"); - sexp_verify_one(sexp_context_lambda(x), x, "context_lambda"); - sexp_verify_one(sexp_context_parent(x), x, "context_parent"); - for (saves=sexp_context_saves(x); saves; saves=saves->next) - if (saves->var) sexp_verify_one(*(saves->var), x, "context_saves"); - sexp_verify_one(sexp_context_stack(x), x, "context_stack"); - break; - case SEXP_STRING: - case SEXP_FLONUM: - case SEXP_CORE: - break; - default: - fprintf(stderr, "verify: unknown type: %d\n", sexp_pointer_tag(x)); - } -} - #define _adjust(x) if (x && (sexp_pointerp(x)) && (start <= (char*)x) && (((char*)x) <= end)) x = (sexp) (((char*)x)+offset) void sexp_adjust_pointers (sexp x, char* start, char* end, size_t offset) { @@ -607,8 +362,6 @@ void validate_heap (sexp ctx) { fprintf(stderr, "bare object found at %p\n", p); } else if (sexp_pointer_tag(p) > SEXP_CONTEXT) { fprintf(stderr, "bad type at %p: %d\n", p, sexp_pointer_tag(p)); - } else { - sexp_verify(p); } p = (sexp) (((char*)p)+size); } diff --git a/opcodes.c b/opcodes.c index 0aee670c..33371854 100644 --- a/opcodes.c +++ b/opcodes.c @@ -1,7 +1,7 @@ #define _OP(c,o,n,m,t,u,i,s,f,d) \ {.tag=SEXP_OPCODE, \ - .value={.opcode={c, o, n, m, t, u, i, s, f, d, NULL}}} + .value={.opcode={c, o, n, m, t, u, i, s, d, f, NULL}}} #define _FN(o,n,m,t,u,s,f,d) _OP(OPC_FOREIGN, o, n, m, t, u, 0, s, f, (sexp)d) #define _FN0(s, f, d) _FN(OP_FCALL0, 0, 0, 0, 0, s, f, d) #define _FN1(t, s, f, d) _FN(OP_FCALL1, 1, 0, t, 0, s, f, d) diff --git a/sexp.c b/sexp.c index 72f5e503..cc4244d9 100644 --- a/sexp.c +++ b/sexp.c @@ -53,38 +53,43 @@ sexp sexp_alloc_tagged(sexp ctx, size_t size, sexp_uint_t tag) { return res; } +#define _TYPE(t,fb,flb,flo,fls,sb,so,sc,n) \ + {.tag=SEXP_TYPE, .value={.type={t,fb,flb,flo,fls,sb,so,sc,n}}} + static struct sexp_struct sexp_types[] = { - {.tag=SEXP_TYPE, .value={.type={SEXP_OBJECT, 0, 0, 0, 0, 0, 0, 0, "object"}}}, - {.tag=SEXP_TYPE, .value={.type={SEXP_TYPE, 0, 0, 0, 0, sexp_sizeof(type), 0, 0, "type"}}}, - {.tag=SEXP_TYPE, .value={.type={SEXP_FIXNUM, 0, 0, 0, 0, 0, 0, 0, "fixnum"}}}, - {.tag=SEXP_TYPE, .value={.type={SEXP_CHAR, 0, 0, 0, 0, 0, 0, 0, "char"}}}, - {.tag=SEXP_TYPE, .value={.type={SEXP_BOOLEAN, 0, 0, 0, 0, 0, 0, 0, "boolean"}}}, - {.tag=SEXP_TYPE, .value={.type={SEXP_PAIR, 0, 0, 0, 0, sexp_sizeof(pair), 0, 0, "pair"}}}, - {.tag=SEXP_TYPE, .value={.type={SEXP_SYMBOL, 0, 0, 0, 0, sexp_sizeof(symbol), 0, 0, "symbol"}}}, - {.tag=SEXP_TYPE, .value={.type={SEXP_STRING, 0, 0, 0, 0, sexp_sizeof(string)+1, offsetof(struct sexp_struct, value.string.length), 1, "string"}}}, - {.tag=SEXP_TYPE, .value={.type={SEXP_VECTOR, 0, 0, 0, 0, sexp_sizeof(vector), offsetof(struct sexp_struct, value.vector.length), 4, "vector"}}}, - {.tag=SEXP_TYPE, .value={.type={SEXP_FLONUM, 0, 0, 0, 0, sexp_sizeof(flonum), 0, 0, "flonum"}}}, - {.tag=SEXP_TYPE, .value={.type={SEXP_BIGNUM, 0, 0, 0, 0, sexp_sizeof(bignum), offsetof(struct sexp_struct, value.bignum.length), 4, "bignum"}}}, - {.tag=SEXP_TYPE, .value={.type={SEXP_IPORT, 0, 0, 0, 0, sexp_sizeof(port), 0, 0, "input-port"}}}, - {.tag=SEXP_TYPE, .value={.type={SEXP_OPORT, 0, 0, 0, 0, sexp_sizeof(port), 0, 0, "output-port"}}}, - {.tag=SEXP_TYPE, .value={.type={SEXP_EXCEPTION, 0, 0, 0, 0, sexp_sizeof(exception), 0, 0, "exception"}}}, - {.tag=SEXP_TYPE, .value={.type={SEXP_PROCEDURE, 0, 0, 0, 0, sexp_sizeof(procedure), 0, 0, "procedure"}}}, - {.tag=SEXP_TYPE, .value={.type={SEXP_MACRO, 0, 0, 0, 0, sexp_sizeof(macro), 0, 0, "macro"}}}, - {.tag=SEXP_TYPE, .value={.type={SEXP_SYNCLO, 0, 0, 0, 0, sexp_sizeof(synclo), 0, 0, "syntactic-closure"}}}, - {.tag=SEXP_TYPE, .value={.type={SEXP_ENV, 0, 0, 0, 0, sexp_sizeof(env), 0, 0, "environment"}}}, - {.tag=SEXP_TYPE, .value={.type={SEXP_BYTECODE, 0, 0, 0, 0, sexp_sizeof(bytecode), offsetof(struct sexp_struct, value.bytecode.length), 1, "bytecode"}}}, - {.tag=SEXP_TYPE, .value={.type={SEXP_CORE, 0, 0, 0, 0, sexp_sizeof(core), 0, 0, "core-form"}}}, - {.tag=SEXP_TYPE, .value={.type={SEXP_OPCODE, 0, 0, 0, 0, sexp_sizeof(opcode), 0, 0, "opcode"}}}, - {.tag=SEXP_TYPE, .value={.type={SEXP_LAMBDA, 0, 0, 0, 0, sexp_sizeof(lambda), 0, 0, "lambda"}}}, - {.tag=SEXP_TYPE, .value={.type={SEXP_CND, 0, 0, 0, 0, sexp_sizeof(cnd), 0, 0, "conditoinal"}}}, - {.tag=SEXP_TYPE, .value={.type={SEXP_REF, 0, 0, 0, 0, sexp_sizeof(ref), 0, 0, "reference"}}}, - {.tag=SEXP_TYPE, .value={.type={SEXP_SET, 0, 0, 0, 0, sexp_sizeof(set), 0, 0, "set!"}}}, - {.tag=SEXP_TYPE, .value={.type={SEXP_SEQ, 0, 0, 0, 0, sexp_sizeof(seq), 0, 0, "sequence"}}}, - {.tag=SEXP_TYPE, .value={.type={SEXP_LIT, 0, 0, 0, 0, sexp_sizeof(lit), 0, 0, "literal"}}}, - {.tag=SEXP_TYPE, .value={.type={SEXP_STACK, 0, 0, 0, 0, sexp_sizeof(stack), offsetof(struct sexp_struct, value.stack.length), 4, "stack"}}}, - {.tag=SEXP_TYPE, .value={.type={SEXP_CONTEXT, 0, 0, 0, 0, sexp_sizeof(context), 0, 0, "context"}}}, + _TYPE(SEXP_OBJECT, 0, 0, 0, 0, 0, 0, 0, "object"), + _TYPE(SEXP_TYPE, 0, 0, 0, 0, sexp_sizeof(type), 0, 0, "type"), + _TYPE(SEXP_FIXNUM, 0, 0, 0, 0, 0, 0, 0, "fixnum"), + _TYPE(SEXP_CHAR, 0, 0, 0, 0, 0, 0, 0, "char"), + _TYPE(SEXP_BOOLEAN, 0, 0, 0, 0, 0, 0, 0, "boolean"), + _TYPE(SEXP_PAIR, sexp_offsetof(pair, car), 2, 0, 0, sexp_sizeof(pair), 0, 0, "pair"), + _TYPE(SEXP_SYMBOL, sexp_offsetof(symbol, string), 1, 0, 0, sexp_sizeof(symbol), 0, 0, "symbol"), + _TYPE(SEXP_STRING, 0, 0, 0, 0, sexp_sizeof(string)+1, sexp_offsetof(string, length), 1, "string"), + _TYPE(SEXP_VECTOR, sexp_offsetof(vector, data), 0, sexp_offsetof(vector, length), 1, sexp_sizeof(vector), sexp_offsetof(vector, length), 4, "vector"), + _TYPE(SEXP_FLONUM, 0, 0, 0, 0, sexp_sizeof(flonum), 0, 0, "flonum"), + _TYPE(SEXP_BIGNUM, 0, 0, 0, 0, sexp_sizeof(bignum), sexp_offsetof(bignum, length), 4, "bignum"), + _TYPE(SEXP_IPORT, sexp_offsetof(port, cookie), 1, 0, 0, sexp_sizeof(port), 0, 0, "input-port"), + _TYPE(SEXP_OPORT, sexp_offsetof(port, cookie), 1, 0, 0, sexp_sizeof(port), 0, 0, "output-port"), + _TYPE(SEXP_EXCEPTION, sexp_offsetof(exception, kind), 6, 0, 0, sexp_sizeof(exception), 0, 0, "exception"), + _TYPE(SEXP_PROCEDURE, sexp_offsetof(procedure, bc), 2, 0, 0, sexp_sizeof(procedure), 0, 0, "procedure"), + _TYPE(SEXP_MACRO, sexp_offsetof(macro, proc), 2, 0, 0, sexp_sizeof(macro), 0, 0, "macro"), + _TYPE(SEXP_SYNCLO, sexp_offsetof(synclo, env), 3, 0, 0, sexp_sizeof(synclo), 0, 0, "syntactic-closure"), + _TYPE(SEXP_ENV, sexp_offsetof(env, parent), 3, 0, 0, sexp_sizeof(env), 0, 0, "environment"), + _TYPE(SEXP_BYTECODE, sexp_offsetof(bytecode, name), 2, 0, 0, sexp_sizeof(bytecode), offsetof(struct sexp_struct, value.bytecode.length), 1, "bytecode"), + _TYPE(SEXP_CORE, 0, 0, 0, 0, sexp_sizeof(core), 0, 0, "core-form"), + _TYPE(SEXP_OPCODE, sexp_offsetof(opcode, dflt), 2, 0, 0, sexp_sizeof(opcode), 0, 0, "opcode"), + _TYPE(SEXP_LAMBDA, sexp_offsetof(lambda, name), 8, 0, 0, sexp_sizeof(lambda), 0, 0, "lambda"), + _TYPE(SEXP_CND, sexp_offsetof(cnd, test), 3, 0, 0, sexp_sizeof(cnd), 0, 0, "conditoinal"), + _TYPE(SEXP_REF, sexp_offsetof(ref, name), 2, 0, 0, sexp_sizeof(ref), 0, 0, "reference"), + _TYPE(SEXP_SET, sexp_offsetof(set, var), 2, 0, 0, sexp_sizeof(set), 0, 0, "set!"), + _TYPE(SEXP_SEQ, sexp_offsetof(seq, ls), 1, 0, 0, sexp_sizeof(seq), 0, 0, "sequence"), + _TYPE(SEXP_LIT, sexp_offsetof(lit, value), 1, 0, 0, sexp_sizeof(lit), 0, 0, "literal"), + _TYPE(SEXP_STACK, sexp_offsetof(stack, data), 0, sexp_offsetof(stack, top), 1, sexp_sizeof(stack), offsetof(struct sexp_struct, value.stack.length), 4, "stack"), + _TYPE(SEXP_CONTEXT, sexp_offsetof(context, bc), 6, 0, 0, sexp_sizeof(context), 0, 0, "context"), }; +#undef _TYPE + #if ! USE_BOEHM #if USE_MALLOC void sexp_deep_free (sexp ctx, sexp obj) { diff --git a/sexp.h b/sexp.h index fc25b43e..620f860c 100644 --- a/sexp.h +++ b/sexp.h @@ -102,8 +102,8 @@ struct sexp_struct { double flonum; struct { sexp_tag_t tag; - sexp_sint_t field_base, field_len_base, field_len_off, field_len_scale; - sexp_sint_t size_base, size_off, size_scale; + short field_base, field_len_base, field_len_off, field_len_scale; + short size_base, size_off, size_scale; char *name; } type; struct { @@ -159,7 +159,7 @@ struct sexp_struct { unsigned char op_class, code, num_args, flags, arg1_type, arg2_type, inverse; char *name; - sexp dflt, data, proc; + sexp data, dflt, proc; } opcode; struct { char code; @@ -167,7 +167,7 @@ struct sexp_struct { } core; /* ast types */ struct { - sexp name, params, locals, defs, flags, body, fv, sv; + sexp name, params, locals, defs, flags, fv, sv, body; } lambda; struct { sexp test, pass, fail; @@ -275,6 +275,8 @@ void *sexp_realloc(sexp ctx, sexp x, size_t size); #define sexp_sizeof(x) (offsetof(struct sexp_struct, value) \ + sizeof(((sexp)0)->value.x)) +#define sexp_offsetof(type, f) (offsetof(struct sexp_struct, value.type.f)) + #define sexp_alloc_type(ctx, type, tag) sexp_alloc_tagged(ctx, sexp_sizeof(type), tag) /***************************** predicates *****************************/ From ba484795d132c9154672ffe965eca0cf6095766f Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 15 Jun 2009 19:04:44 +0900 Subject: [PATCH 121/154] considering adjusting heap a dead-end for now --- config.h | 6 ++ defaults.h | 4 ++ gc.c | 162 ++++++++++++++++++++--------------------------------- 3 files changed, 71 insertions(+), 101 deletions(-) diff --git a/config.h b/config.h index 9b2ec71c..4b254b17 100644 --- a/config.h +++ b/config.h @@ -5,6 +5,12 @@ /* uncomment this to use the Boehm conservative GC */ /* #define USE_BOEHM 1 */ +/* uncomment this to just malloc manually instead of any GC */ +/* #define USE_MALLOC 1 */ + +/* uncomment this to add conservative checks to the native GC */ +/* #define USE_DEBUG_GC 1 */ + /* uncomment this if you only want fixnum support */ /* #define USE_FLONUMS 0 */ diff --git a/defaults.h b/defaults.h index ad53a516..f6d586e0 100644 --- a/defaults.h +++ b/defaults.h @@ -24,6 +24,10 @@ #define USE_MALLOC 0 #endif +#ifndef USE_DEBUG_GC +#define USE_DEBUG_GC 0 +#endif + #ifndef USE_FLONUMS #define USE_FLONUMS 1 #endif diff --git a/gc.c b/gc.c index 3ab32086..636e2579 100644 --- a/gc.c +++ b/gc.c @@ -51,88 +51,6 @@ void sexp_mark (sexp x) { } } -#define _adjust(x) if (x && (sexp_pointerp(x)) && (start <= (char*)x) && (((char*)x) <= end)) x = (sexp) (((char*)x)+offset) - -void sexp_adjust_pointers (sexp x, char* start, char* end, size_t offset) { - sexp *data; - sexp_uint_t i; - struct sexp_gc_var_t *saves; - switch (sexp_pointer_tag(x)) { - case SEXP_PAIR: - _adjust(sexp_car(x)); _adjust(sexp_cdr(x)); break; - case SEXP_STACK: - data = sexp_stack_data(x); - for (i=sexp_stack_top(x)-1; i>=0; i--) - _adjust(data[i]); - break; - case SEXP_VECTOR: - data = sexp_vector_data(x); - for (i=sexp_vector_length(x)-1; i>=0; i--) - _adjust(data[i]); - break; - case SEXP_SYMBOL: - _adjust(sexp_symbol_string(x)); break; - case SEXP_BYTECODE: - _adjust(sexp_bytecode_literals(x)); break; - case SEXP_ENV: - _adjust(sexp_env_lambda(x)); - _adjust(sexp_env_bindings(x)); - _adjust(sexp_env_parent(x)); - break; - case SEXP_PROCEDURE: - _adjust(sexp_procedure_code(x)); _adjust(sexp_procedure_vars(x)); break; - case SEXP_MACRO: - _adjust(sexp_macro_proc(x)); _adjust(sexp_macro_env(x)); break; - case SEXP_SYNCLO: - _adjust(sexp_synclo_free_vars(x)); - _adjust(sexp_synclo_expr(x)); - _adjust(sexp_synclo_env(x)); - break; - case SEXP_OPCODE: - _adjust(sexp_opcode_proc(x)); - _adjust(sexp_opcode_default(x)); - _adjust(sexp_opcode_data(x)); - break; - case SEXP_IPORT: - case SEXP_OPORT: - _adjust(sexp_port_cookie(x)); - case SEXP_LAMBDA: - _adjust(sexp_lambda_name(x)); - _adjust(sexp_lambda_params(x)); - _adjust(sexp_lambda_locals(x)); - _adjust(sexp_lambda_defs(x)); - _adjust(sexp_lambda_flags(x)); - _adjust(sexp_lambda_body(x)); - _adjust(sexp_lambda_fv(x)); - _adjust(sexp_lambda_sv(x)); - _adjust(sexp_lambda_body(x)); - break; - case SEXP_CND: - _adjust(sexp_cnd_test(x)); - _adjust(sexp_cnd_fail(x)); - _adjust(sexp_cnd_pass(x)); - break; - case SEXP_SET: - _adjust(sexp_set_var(x)); _adjust(sexp_set_value(x)); break; - case SEXP_REF: - _adjust(sexp_ref_name(x)); _adjust(sexp_ref_cell(x)); break; - case SEXP_SEQ: - _adjust(sexp_seq_ls(x)); break; - case SEXP_LIT: - _adjust(sexp_lit_value(x)); break; - case SEXP_CONTEXT: - _adjust(sexp_context_env(x)); - _adjust(sexp_context_bc(x)); - _adjust(sexp_context_fv(x)); - _adjust(sexp_context_lambda(x)); - _adjust(sexp_context_parent(x)); - for (saves=sexp_context_saves(x); saves; saves=saves->next) - if (saves->var) _adjust(*(saves->var)); - _adjust(sexp_context_stack(x)); - break; - } -} - void simple_write (sexp obj, int depth, FILE *out) { unsigned long len, c, res; long i=0; @@ -328,7 +246,7 @@ void sexp_show_free_list (sexp ctx) { putc('\n', stderr); } -void validate_free_list (sexp ctx) { +void validate_free_list () { sexp p=sexp_free_list, prev=NULL; while (p && sexp_pairp(p) && ((char*) p < sexp_heap_end)) { if (((char*)p < sexp_heap) || ((char*)p >= sexp_heap_end)) @@ -518,15 +436,53 @@ sexp sexp_gc (sexp ctx) { res = sexp_sweep(ctx); fprintf(stderr, "************* post gc validation *************\n"); validate_heap(ctx); - validate_free_list(ctx); + validate_free_list(); validate_gc_vars(ctx); fprintf(stderr, "************* done post gc validation *************\n"); return res; } -void sexp_adjust_heap (char *start, char *end, size_t offset, size_t new_size) { - sexp p=(sexp)(start+sexp_align(SEXP_MINIMUM_OBJECT_SIZE, 4)); - sexp q=(sexp)(((char*)sexp_free_list)+offset), r; +#define _adjust(x) if ((x) && (sexp_pointerp(x))) (x) = (sexp) (((char*)(x))+offset) + +void sexp_adjust_pointers (sexp x, sexp_sint_t offset) { + sexp_uint_t *len_ptr; + sexp_sint_t i, len; + sexp t, *p; + struct sexp_gc_var_t *saves; + + if ((! x) || (! sexp_pointerp(x))) + return; + if (sexp_contextp(x)) + for (saves=sexp_context_saves(x); saves; saves=saves->next) + if (saves->var) _adjust(*(saves->var)); + t = &(sexp_types[sexp_pointer_tag(x)]); + p = (sexp*) (((char*)x) + sexp_type_field_base(t)); + len_ptr = (sexp_uint_t*) (((char*)x) + sexp_type_field_len_off(t)); + len = sexp_type_field_len_base(t) + len_ptr[0]*sexp_type_field_len_scale(t); + for (i=0; i (sexp)(start-offset)) && (*t < (sexp)(end-offset))) + fprintf(stderr, "bad address at %p: %p\n", t, *t); } +void* sexp_realloc_heap (char *heap, size_t cur_size, size_t new_size) { + char *res = malloc(new_size); + memcpy(res, heap, cur_size); + return res; +} + +/* #define sexp_realloc_heap(h, cs, ns) realloc(h, ns) */ + int sexp_grow_heap (sexp ctx, size_t size) { char *tmp1, *tmp2; sexp q; @@ -562,13 +520,14 @@ int sexp_grow_heap (sexp ctx, size_t size) { fprintf(stderr, "************* heap too large *************\n"); return 0; } - if (! (tmp1 = realloc(sexp_heap, new_size))) { + if (! (tmp1 = sexp_realloc_heap(sexp_heap, cur_size, new_size))) { fprintf(stderr, "************* couldn't realloc *************\n"); return 0; } if (tmp1 != sexp_heap) { - fprintf(stderr, "************* adjusting heap pointers *************\n"); + fprintf(stderr, "************* adjusting heap: %p => %p (%d) *************\n", sexp_heap, tmp1, tmp1-sexp_heap); sexp_adjust_heap(tmp1, tmp1+cur_size, tmp1-sexp_heap, new_size); + fprintf(stderr, "************* done adjusting *************\n"); tmp2 = sexp_heap; sexp_heap = tmp1; free(tmp2); @@ -584,6 +543,7 @@ int sexp_grow_heap (sexp ctx, size_t size) { sexp_cdr(q) = SEXP_NULL; } sexp_heap_end = sexp_heap + new_size; + sexp_show_free_list(ctx); return 1; } From 39fdd89474f745b739299943e716e292c95d6588 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Wed, 17 Jun 2009 22:37:21 +0900 Subject: [PATCH 122/154] not trying to adjust the heap, just keeping a linked list of heap chunks. expanding the heap thus works now, so i've removed all the debugging utils from gc.c, except the conservative checks which are now a config option. --- eval.c | 25 ++- gc.c | 619 +++++++++++---------------------------------------------- sexp.c | 2 +- sexp.h | 19 +- 4 files changed, 136 insertions(+), 529 deletions(-) diff --git a/eval.c b/eval.c index b7a8fe1b..758eaab3 100644 --- a/eval.c +++ b/eval.c @@ -363,26 +363,29 @@ static sexp sexp_compile_error(sexp ctx, char *message, sexp obj) { } while (0) static sexp analyze_app (sexp ctx, sexp x) { - sexp tmp; sexp_gc_var(ctx, res, s_res); + sexp_gc_var(ctx, tmp, s_tmp); sexp_gc_preserve(ctx, res, s_res); + sexp_gc_preserve(ctx, tmp, s_tmp); for (res=SEXP_NULL; sexp_pairp(x); x=sexp_cdr(x)) { sexp_push(ctx, res, SEXP_FALSE); tmp = analyze(ctx, sexp_car(x)); if (sexp_exceptionp(tmp)) { res = tmp; break; - } else + } else { sexp_car(res) = tmp; + } } sexp_gc_release(ctx, res, s_res); return (sexp_pairp(res) ? sexp_nreverse(ctx, res) : res); } static sexp analyze_seq (sexp ctx, sexp ls) { - sexp tmp; sexp_gc_var(ctx, res, s_res); + sexp_gc_var(ctx, tmp, s_tmp); sexp_gc_preserve(ctx, res, s_res); + sexp_gc_preserve(ctx, tmp, s_tmp); if (sexp_nullp(ls)) res = SEXP_VOID; else if (sexp_nullp(sexp_cdr(ls))) @@ -517,13 +520,16 @@ static sexp analyze_if (sexp ctx, sexp x) { } static sexp analyze_define (sexp ctx, sexp x) { - sexp name, res, env = sexp_context_env(ctx); + sexp name, res; sexp_gc_var(ctx, ref, s_ref); sexp_gc_var(ctx, value, s_value); sexp_gc_var(ctx, tmp, s_tmp); + sexp_gc_var(ctx, env, s_env); sexp_gc_preserve(ctx, ref, s_ref); sexp_gc_preserve(ctx, value, s_value); sexp_gc_preserve(ctx, tmp, s_tmp); + sexp_gc_preserve(ctx, env, s_env); + env = sexp_context_env(ctx); name = (sexp_pairp(sexp_cadr(x)) ? sexp_caadr(x) : sexp_cadr(x)); if (sexp_env_lambda(env) && sexp_lambdap(sexp_env_lambda(env))) { tmp = sexp_cons(ctx, name, sexp_context_lambda(ctx)); @@ -613,13 +619,15 @@ static sexp analyze_letrec_syntax (sexp ctx, sexp x) { } static sexp analyze (sexp ctx, sexp object) { - sexp op, cell; + sexp op; sexp_gc_var(ctx, res, s_res); sexp_gc_var(ctx, tmp, s_tmp); sexp_gc_var(ctx, x, s_x); + sexp_gc_var(ctx, cell, s_cell); sexp_gc_preserve(ctx, res, s_res); sexp_gc_preserve(ctx, tmp, s_tmp); sexp_gc_preserve(ctx, x, s_x); + sexp_gc_preserve(ctx, cell, s_cell); x = object; loop: if (sexp_pairp(x)) { @@ -1104,15 +1112,19 @@ static sexp make_param_list(sexp ctx, sexp_uint_t i) { } static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i) { - sexp ctx2, lambda, ls, bc, res, env; + sexp ls, bc, res, env; sexp_gc_var(ctx, params, s_params); sexp_gc_var(ctx, ref, s_ref); sexp_gc_var(ctx, refs, s_refs); + sexp_gc_var(ctx, lambda, s_lambda); + sexp_gc_var(ctx, ctx2, s_ctx2); if (i == sexp_opcode_num_args(op) && sexp_opcode_proc(op)) return sexp_opcode_proc(op); /* return before preserving */ sexp_gc_preserve(ctx, params, s_params); sexp_gc_preserve(ctx, ref, s_ref); sexp_gc_preserve(ctx, refs, s_refs); + sexp_gc_preserve(ctx, lambda, s_lambda); + sexp_gc_preserve(ctx, ctx2, s_ctx2); params = make_param_list(ctx, i); lambda = sexp_make_lambda(ctx, params); ctx2 = sexp_make_child_context(ctx, lambda); @@ -1201,7 +1213,6 @@ sexp vm (sexp ctx, sexp proc) { fprintf(stderr, "%s\n", (*ip<=71)?reverse_opcode_names[*ip]:"UNKNOWN"); } #endif - sexp_context_top(ctx) = top; /* debugging */ switch (*ip++) { case OP_NOOP: break; diff --git a/gc.c b/gc.c index 636e2579..0f5c63d7 100644 --- a/gc.c +++ b/gc.c @@ -4,16 +4,22 @@ #include "sexp.h" -/* #define SEXP_INITIAL_HEAP_SIZE (3*1024*1024) */ -#define SEXP_INITIAL_HEAP_SIZE 37000 +#define SEXP_INITIAL_HEAP_SIZE (2*1024*1024) #define SEXP_MAXIMUM_HEAP_SIZE 0 #define SEXP_MINIMUM_OBJECT_SIZE (sexp_sizeof(flonum)) -static char* sexp_heap; -static char* sexp_heap_end; -static sexp sexp_free_list; +typedef struct sexp_heap *sexp_heap; +struct sexp_heap { + sexp_uint_t size; + sexp free_list; + sexp_heap next; + char *data; +}; + +static sexp_heap heap; static sexp* stack_base; +extern sexp continuation_resumer, final_resumer; sexp_uint_t sexp_allocated_bytes (sexp x) { sexp_uint_t res, *len_ptr; @@ -51,531 +57,149 @@ void sexp_mark (sexp x) { } } -void simple_write (sexp obj, int depth, FILE *out) { - unsigned long len, c, res; - long i=0; - double f; - char *str=NULL; - - if (! obj) { - fputs("#", out); - } else if (! sexp_pointerp(obj)) { - if (sexp_integerp(obj)) { - fprintf(out, "%ld", sexp_unbox_integer(obj)); - } else if (sexp_charp(obj)) { - if (obj == sexp_make_character(' ')) - fputs("#\\space", out); - else if (obj == sexp_make_character('\n')) - fputs("#\\newline", out); - else if (obj == sexp_make_character('\r')) - fputs("#\\return", out); - else if (obj == sexp_make_character('\t')) - fputs("#\\tab", out); - else if ((33 <= sexp_unbox_character(obj)) - && (sexp_unbox_character(obj) < 127)) - fprintf(out, "#\\%c", sexp_unbox_character(obj)); - else - fprintf(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" - putc(res, out); - } - } -#endif - - } else { - switch ((sexp_uint_t) obj) { - case (sexp_uint_t) SEXP_NULL: - fputs("()", out); break; - case (sexp_uint_t) SEXP_TRUE: - fputs("#t", out); break; - case (sexp_uint_t) SEXP_FALSE: - fputs("#f", out); break; - case (sexp_uint_t) SEXP_EOF: - fputs("#", out); break; - case (sexp_uint_t) SEXP_UNDEF: - case (sexp_uint_t) SEXP_VOID: - fputs("#", out); break; - default: - fprintf(out, "#", obj); - } - } - } else if (depth <= 0) { - fprintf(out, "#<...>"); - } else { - switch (sexp_pointer_tag(obj)) { - case SEXP_PAIR: - putc('(', out); - simple_write(sexp_car(obj), depth-1, out); - if (sexp_pairp(sexp_cdr(obj))) { - fputs(" ...", out); - } else if (! sexp_nullp(sexp_cdr(obj))) { - fputs(" . ", out); - simple_write(sexp_cdr(obj), depth-1, out); - } - putc(')', out); - break; - case SEXP_VECTOR: - len = sexp_vector_length(obj); - if (len == 0) { - fputs("#()", out); - } else { - fprintf(out, "#(... %ld ...)", len); - } - break; - case SEXP_FLONUM: - f = sexp_flonum_value(obj); - fprintf(out, "%.15g%s", f, (f == trunc(f)) ? ".0" : ""); - break; - case SEXP_PROCEDURE: - fputs("#', out); - break; - case SEXP_IPORT: - fputs("#", out); break; - case SEXP_OPORT: - fputs("#", out); break; - case SEXP_CORE: - fputs("#", out); break; - case SEXP_OPCODE: - fputs("#", out); break; - case SEXP_BYTECODE: - fputs("#", out); break; - case SEXP_ENV: - fprintf(out, "#", obj); break; - case SEXP_EXCEPTION: - fputs("#", out); break; - case SEXP_MACRO: - fputs("#", out); break; - case SEXP_LAMBDA: - fputs("#', out); - break; - case SEXP_SEQ: - fputs("#', out); - break; - case SEXP_CND: - fputs("#', out); - break; - case SEXP_REF: - fputs("#", sexp_ref_loc(obj)); - break; - case SEXP_SET: - fputs("#', out); - break; - case SEXP_LIT: - fputs("#', out); - break; - case SEXP_CONTEXT: - fputs("#", out); - break; - case SEXP_SYNCLO: - fputs("#', out); - break; - case SEXP_STRING: - putc('"', out); - i = sexp_string_length(obj); - str = sexp_string_data(obj); - for ( ; i>0; str++, i--) { - switch (str[0]) { - case '\\': fputs("\\\\", out); break; - case '"': fputs("\\\"", out); break; - case '\n': fputs("\\n", out); break; - case '\r': fputs("\\r", out); break; - case '\t': fputs("\\t", out); break; - default: putc(str[0], out); - } - } - putc('"', out); - break; - case SEXP_SYMBOL: - i = sexp_string_length(sexp_symbol_string(obj)); - str = sexp_string_data(sexp_symbol_string(obj)); - for ( ; i>0; str++, i--) { - if ((str[0] == '\\') || is_separator(str[0])) - putc('\\', out); - putc(str[0], out); - } - break; - default: - fprintf(out, "#", sexp_pointer_tag(obj)); - break; - } - } -} - -void sexp_show_free_list (sexp ctx) { - sexp p=sexp_free_list, prev=NULL; - fputs("free-list:", stderr); - while (p && sexp_pairp(p) && ((char*) p < sexp_heap_end)) { - if (p < prev) { - fprintf(stderr, " \x1B[31m%p-%p\x1B[0m", p, ((char*)p)+(sexp_uint_t)sexp_car(p)); - } else { - fprintf(stderr, " %p-%p", p, ((char*)p)+(sexp_uint_t)sexp_car(p)); - } - prev = (sexp) (((char*)p)+(sexp_uint_t)sexp_car(p)); - p = sexp_cdr(p); - } - putc('\n', stderr); -} - -void validate_free_list () { - sexp p=sexp_free_list, prev=NULL; - while (p && sexp_pairp(p) && ((char*) p < sexp_heap_end)) { - if (((char*)p < sexp_heap) || ((char*)p >= sexp_heap_end)) - fprintf(stderr, " \x1B[31mfree-list outside heap: %p prev: %p\x1B[0m", p, prev); - if (p < prev) - fprintf(stderr, " \x1B[31mfree-list out of order at: %p prev: %p cdr: %p\x1B[0m", p, prev, sexp_cdr(p)); - if ((sexp_uint_t)p != sexp_align((sexp_uint_t)p, 4)) - fprintf(stderr, " \x1B[31mfree-list misaligned: %p prev: %p\x1B[0m", p, prev); - prev = (sexp) (((char*)p)+(sexp_uint_t)sexp_car(p)); - p = sexp_cdr(p); - } -} - -void validate_heap (sexp ctx) { - sexp_uint_t size; - sexp p=(sexp)(sexp_heap+sexp_align(SEXP_MINIMUM_OBJECT_SIZE, 4)); - sexp q=sexp_free_list, r; - /* scan over the whole heap */ - while (((char*)p) < sexp_heap_end) { - /* find the preceding and succeeding free list pointers */ - for (r=sexp_cdr(q); r && sexp_pairp(r) && (r= 0x29e00) && ((sexp_uint_t)p <= 0x2a000)) */ - /* fprintf(stderr, "validate heap: %p (%p .. %p)\n", p, q, r); */ - size = sexp_align(sexp_allocated_bytes(p), 4); - if (sexp_pointer_tag(p) == 0) { - fprintf(stderr, "bare object found at %p\n", p); - } else if (sexp_pointer_tag(p) > SEXP_CONTEXT) { - fprintf(stderr, "bad type at %p: %d\n", p, sexp_pointer_tag(p)); - } - p = (sexp) (((char*)p)+size); - } -} - -void validate_gc_vars (sexp ctx) { - struct sexp_gc_var_t *saves, *prev=NULL; - if (! ctx) - return; - for (saves=sexp_context_saves(ctx); saves; saves=saves->next) { - if (saves->var && *(saves->var) && sexp_pointerp(*(saves->var))) { - if (((char*)*(saves->var) < sexp_heap) - || ((char*)*(saves->var) >= sexp_heap_end)) - fprintf(stderr, "bad variable in gc var: %s => %p\n", saves->name, *(saves->var)); - if ((sexp_uint_t)*(saves->var) - != sexp_align((sexp_uint_t)*(saves->var), 4)) - fprintf(stderr, "misaligned gc var: %p\n", *(saves->var)); - } - if (prev && (prev > saves)) { - fprintf(stderr, "gc vars out of order: %p > %p\n", prev, saves); - return; - } else if (prev == saves) { - fprintf(stderr, "loop in gc vars at %p\n", saves); - return; - } - prev = saves; - } -} - -int validate_freed_pointer (sexp ctx, sexp x) { - int freep = 1; +#ifdef USE_DEBUG_GC +int stack_references_pointer_p (sexp ctx, sexp x) { sexp *p; - struct sexp_gc_var_t *saves, *prev=NULL; - char *v1, *v2; - - for (p=&x; pnext) { - if (saves->var && prev && prev->var - && (((saves->var <= p) && (prev->var >= p)) - || ((saves->var >= p) && (prev->var <= p)))) { - v1 = saves->name; - v2 = prev->name; - break; - } - prev = saves; - } - if (v1 && v2) - fprintf(stderr, "reference to freed var %p at %p between %s and %s: ", - x, p, v1, v2); - else if (sexp_context_saves(ctx) && (p <= sexp_context_saves(ctx)->var)) - fprintf(stderr, "reference to freed var %p at %p after %s: ", - x, p, sexp_context_saves(ctx)->name); - else if (prev && (p >= prev->var)) - fprintf(stderr, "reference to freed var %p at %p before %s: ", - x, p, prev->name); - else - fprintf(stderr, "reference to freed var %p at %p: ", x, p); - simple_write(x, 1, stderr); - putc('\n', stderr); - freep = 0; - } - } - - return freep; + for (p=&x; pnext) { + p = (sexp) (h->data + sexp_align(sexp_sizeof(pair), 4)); + q = h->free_list; + end = (char*)h->data + h->size; + while (((char*)p) < end) { + /* find the preceding and succeeding free list pointers */ + for (r=sexp_cdr(q); r && sexp_pairp(r) && (rfree_list)) { + /* merge q with p */ + if (r && sexp_pairp(r) && ((((char*)p)+size) == (char*)r)) { + /* ... and with r */ + sexp_cdr(q) = sexp_cdr(r); + freed = (sexp_uint_t)sexp_car(q) + size + (sexp_uint_t)sexp_car(r); + p = (sexp) (((char*)p)+size+(sexp_uint_t)sexp_car(r)); + } else { + freed = (sexp_uint_t)sexp_car(q) + size; + p = (sexp) (((char*)p)+size); + } + sexp_car(q) = (sexp)freed; + } else { + if (r && sexp_pairp(r) && ((((char*)p)+size) == (char*)r)) { + sexp_car(p) = (sexp)(size+(sexp_uint_t)sexp_car(r)); + sexp_cdr(p) = sexp_cdr(r); + sexp_cdr(q) = p; + freed = size + (sexp_uint_t)sexp_car(r); + } else { + sexp_car(p) = (sexp)size; + sexp_cdr(p) = r; + sexp_cdr(q) = p; + freed = size; + } + sexp_pointer_tag(p) = SEXP_PAIR; + p = (sexp) (((char*)p)+freed); + } + if (freed > max_freed) + max_freed = freed; + } else { + sexp_gc_mark(p) = 0; + p = (sexp) (((char*)p)+size); } - if (freed > max_freed) - max_freed = freed; - } else { -/* fprintf(stderr, "\x1B[32msaving %lu bytes @ %p (%x) ", size, p, sexp_pointer_tag(p)); */ -/* simple_write(p, 1, stderr); */ -/* fprintf(stderr, "\x1B[0m\n"); */ - sexp_gc_mark(p) = 0; - p = (sexp) (((char*)p)+size); } } - fprintf(stderr, "**************** freed %ld bytes, max %ld ****************\n", sum_freed, max_freed); return sexp_make_integer(max_freed); } -extern sexp continuation_resumer, final_resumer; - sexp sexp_gc (sexp ctx) { sexp res; int i; - fprintf(stderr, "************* garbage collecting *************\n"); - /* sexp_show_free_list(ctx); */ sexp_mark(continuation_resumer); sexp_mark(final_resumer); for (i=0; inext) - if (saves->var) _adjust(*(saves->var)); - t = &(sexp_types[sexp_pointer_tag(x)]); - p = (sexp*) (((char*)x) + sexp_type_field_base(t)); - len_ptr = (sexp_uint_t*) (((char*)x) + sexp_type_field_len_off(t)); - len = sexp_type_field_len_base(t) + len_ptr[0]*sexp_type_field_len_scale(t); - for (i=0; isize = size; + h->data = (char*) sexp_align((sexp_uint_t)&(h->data), 4); + free = h->free_list = (sexp) h->data; + h->next = NULL; + next = (sexp) ((char*)free + sexp_align(sexp_sizeof(pair), 4)); + sexp_pointer_tag(free) = SEXP_PAIR; + sexp_car(free) = 0; /* actually sexp_sizeof(pair) */ + sexp_cdr(free) = next; + sexp_pointer_tag(next) = SEXP_PAIR; + sexp_car(next) = (sexp) (size - sexp_align(sexp_sizeof(pair), 4)); + sexp_cdr(next) = SEXP_NULL; } - fprintf(stderr, "************* done adjusting heap *************\n"); - for (t=(sexp*)start; t<(sexp*)end; t++) - if (*t && sexp_pointerp(*t) - && (*t > (sexp)(start-offset)) && (*t < (sexp)(end-offset))) - fprintf(stderr, "bad address at %p: %p\n", t, *t); + return h; } -void* sexp_realloc_heap (char *heap, size_t cur_size, size_t new_size) { - char *res = malloc(new_size); - memcpy(res, heap, cur_size); - return res; -} - -/* #define sexp_realloc_heap(h, cs, ns) realloc(h, ns) */ - int sexp_grow_heap (sexp ctx, size_t size) { - char *tmp1, *tmp2; - sexp q; - size_t cur_size = sexp_heap_end - sexp_heap, new_size; + size_t cur_size, new_size; + sexp_heap h; + for (h=heap; h->next; h=h->next) + ; + cur_size = h->size; new_size = sexp_align(((cur_size > size) ? cur_size : size) * 2, 4); - fprintf(stderr, "************* growing heap *************\n"); - validate_heap(ctx); - if (SEXP_MAXIMUM_HEAP_SIZE && (new_size > SEXP_MAXIMUM_HEAP_SIZE)) { - fprintf(stderr, "************* heap too large *************\n"); - return 0; - } - if (! (tmp1 = sexp_realloc_heap(sexp_heap, cur_size, new_size))) { - fprintf(stderr, "************* couldn't realloc *************\n"); - return 0; - } - if (tmp1 != sexp_heap) { - fprintf(stderr, "************* adjusting heap: %p => %p (%d) *************\n", sexp_heap, tmp1, tmp1-sexp_heap); - sexp_adjust_heap(tmp1, tmp1+cur_size, tmp1-sexp_heap, new_size); - fprintf(stderr, "************* done adjusting *************\n"); - tmp2 = sexp_heap; - sexp_heap = tmp1; - free(tmp2); - } else { - for (q = sexp_free_list; - sexp_cdr(q) && sexp_pairp(sexp_cdr(q)); - q = sexp_cdr(q)) - ; - sexp_cdr(q) = (sexp) sexp_heap_end; - q = sexp_cdr(q); - sexp_pointer_tag(q) = SEXP_PAIR; - sexp_car(q) = (sexp) (new_size - cur_size); - sexp_cdr(q) = SEXP_NULL; - } - sexp_heap_end = sexp_heap + new_size; - sexp_show_free_list(ctx); - return 1; + h->next = sexp_make_heap(new_size); + return (h->next != NULL); } void* sexp_try_alloc (sexp ctx, size_t size) { sexp ls1, ls2, ls3; - ls1 = sexp_free_list; - ls2 = sexp_cdr(ls1); - while (sexp_pairp(ls2)) { - if ((sexp_uint_t)sexp_car(ls2) >= size) { - if ((sexp_uint_t)sexp_car(ls2) >= (size + SEXP_MINIMUM_OBJECT_SIZE)) { - ls3 = (sexp) (((char*)ls2)+size); /* the free tail after ls2 */ - sexp_pointer_tag(ls3) = SEXP_PAIR; - sexp_car(ls3) = (sexp) (((sexp_uint_t)sexp_car(ls2)) - size); - sexp_cdr(ls3) = sexp_cdr(ls2); - sexp_cdr(ls1) = ls3; - } else { /* take the whole chunk */ - sexp_cdr(ls1) = sexp_cdr(ls2); + sexp_heap h; + for (h=heap; h; h=h->next) { + ls1 = h->free_list; + ls2 = sexp_cdr(ls1); + while (sexp_pairp(ls2)) { + if ((sexp_uint_t)sexp_car(ls2) >= size) { + if ((sexp_uint_t)sexp_car(ls2) >= (size + SEXP_MINIMUM_OBJECT_SIZE)) { + ls3 = (sexp) (((char*)ls2)+size); /* the free tail after ls2 */ + sexp_pointer_tag(ls3) = SEXP_PAIR; + sexp_car(ls3) = (sexp) (((sexp_uint_t)sexp_car(ls2)) - size); + sexp_cdr(ls3) = sexp_cdr(ls2); + sexp_cdr(ls1) = ls3; + } else { /* take the whole chunk */ + sexp_cdr(ls1) = sexp_cdr(ls2); + } + bzero((void*)ls2, size); + return ls2; } - bzero((void*)ls2, size); - return ls2; + ls1 = ls2; + ls2 = sexp_cdr(ls2); } - ls1 = ls2; - ls2 = sexp_cdr(ls2); } return NULL; } void* sexp_alloc (sexp ctx, size_t size) { void *res; -/* validate_heap(ctx); */ -/* validate_free_list(ctx); */ -/* validate_gc_vars(ctx); */ size = sexp_align(size, 4); res = sexp_try_alloc(ctx, size); if (! res) { @@ -590,25 +214,12 @@ void* sexp_alloc (sexp ctx, size_t size) { exit(70); } } - /* fprintf(stderr, "sexp_alloc %lu => %p\n", size, res); */ return res; } void sexp_gc_init () { sexp_uint_t size = sexp_align(SEXP_INITIAL_HEAP_SIZE, 4); - sexp next; - sexp_heap = malloc(size); - sexp_heap_end = sexp_heap + size; - sexp_free_list = (sexp)sexp_heap; - next = (sexp) (sexp_heap + sexp_align(sexp_sizeof(pair), 4)); - sexp_pointer_tag(sexp_free_list) = SEXP_PAIR; - sexp_car(sexp_free_list) = 0; /* actually sexp_sizeof(pair) */ - sexp_cdr(sexp_free_list) = next; - sexp_pointer_tag(next) = SEXP_PAIR; - sexp_car(next) = (sexp) (size - sexp_align(sexp_sizeof(pair), 4)); - sexp_cdr(next) = SEXP_NULL; - stack_base = &next + 32; - fprintf(stderr, "heap: %p - %p, next: %p, stack_base: %p\n", - sexp_heap, sexp_heap_end, next, stack_base); + heap = sexp_make_heap(size); + stack_base = ((sexp*)&size) + 32; } diff --git a/sexp.c b/sexp.c index cc4244d9..79269495 100644 --- a/sexp.c +++ b/sexp.c @@ -84,7 +84,7 @@ static struct sexp_struct sexp_types[] = { _TYPE(SEXP_SET, sexp_offsetof(set, var), 2, 0, 0, sexp_sizeof(set), 0, 0, "set!"), _TYPE(SEXP_SEQ, sexp_offsetof(seq, ls), 1, 0, 0, sexp_sizeof(seq), 0, 0, "sequence"), _TYPE(SEXP_LIT, sexp_offsetof(lit, value), 1, 0, 0, sexp_sizeof(lit), 0, 0, "literal"), - _TYPE(SEXP_STACK, sexp_offsetof(stack, data), 0, sexp_offsetof(stack, top), 1, sexp_sizeof(stack), offsetof(struct sexp_struct, value.stack.length), 4, "stack"), + _TYPE(SEXP_STACK, sexp_offsetof(stack, data), 1, sexp_offsetof(stack, top), 1, sexp_sizeof(stack), offsetof(struct sexp_struct, value.stack.length), 4, "stack"), _TYPE(SEXP_CONTEXT, sexp_offsetof(context, bc), 6, 0, 0, sexp_sizeof(context), 0, 0, "context"), }; diff --git a/sexp.h b/sexp.h index 620f860c..bded73f8 100644 --- a/sexp.h +++ b/sexp.h @@ -224,8 +224,8 @@ struct sexp_struct { #else -#define sexp_gc_var(ctx, x, y) \ - sexp x = SEXP_VOID; \ +#define sexp_gc_var(ctx, x, y) \ + sexp x = SEXP_VOID; \ struct sexp_gc_var_t y = {NULL, NULL}; #define sexp_gc_preserve(ctx, x, y) \ @@ -255,21 +255,6 @@ void *sexp_realloc(sexp ctx, sexp x, size_t size); #endif #endif -#define sexp_with_gc_var1(ctx, x, body) \ - sexp_gc_var(ctx, x, _sexp_gcv1); \ - sexp_gc_preserve(ctx, x, _sexp_gcv1); \ - do {body} while (0); \ - sexp_gc_release(ctx, x, _sexp_gcv1); - -#define sexp_with_gc_var2(ctx, x, y, body) \ - sexp_gc_var(ctx, x, _sexp_gcv1); \ - sexp_gc_var(ctx, y, _sexp_gcv2); \ - sexp_gc_preserve(ctx, x, _sexp_gcv1); \ - sexp_gc_preserve(ctx, y, _sexp_gcv2); \ - do {body} while (0); \ - sexp_gc_release(ctx, x, _sexp_gcv1); \ - sexp_gc_release(ctx, y, _sexp_gcv2); - #define sexp_align(n, bits) (((n)+(1<<(bits))-1)&(((sexp_uint_t)-1)-((1<<(bits))-1))) #define sexp_sizeof(x) (offsetof(struct sexp_struct, value) \ From 7e3014ba38e2ca49e094cbd8ab8c70ccbc58b014 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 18 Jun 2009 00:36:39 +0900 Subject: [PATCH 123/154] cleanup, removing mid-function returns which could corrupt the gc_var trace. --- Makefile | 2 +- eval.c | 190 ++++++++++++++----------- gc.c | 33 +++-- sexp-huff.c => opt/sexp-huff.c | 0 sexp-hufftabs.c => opt/sexp-hufftabs.c | 0 sexp-unhuff.c => opt/sexp-unhuff.c | 0 sexp.c | 147 +++++++++---------- sexp.h | 2 + 8 files changed, 205 insertions(+), 169 deletions(-) rename sexp-huff.c => opt/sexp-huff.c (100%) rename sexp-hufftabs.c => opt/sexp-hufftabs.c (100%) rename sexp-unhuff.c => opt/sexp-unhuff.c (100%) diff --git a/Makefile b/Makefile index cc7450df..ccf712fb 100644 --- a/Makefile +++ b/Makefile @@ -12,7 +12,7 @@ MODDIR=$(PREFIX)/share/chibi-scheme LDFLAGS=-lm # -Oz for smaller size on darwin -CFLAGS=-Wall -g -save-temps +CFLAGS=-Wall -O2 -g -save-temps ./gc/gc.a: ./gc/alloc.c cd gc && make diff --git a/eval.c b/eval.c index 758eaab3..2145fdc3 100644 --- a/eval.c +++ b/eval.c @@ -246,12 +246,14 @@ static sexp sexp_make_lit(sexp ctx, sexp value) { return res; } +#define SEXP_STACK_SIZE (sexp_sizeof(stack)+sizeof(sexp)*INIT_STACK_SIZE) + static sexp sexp_make_context(sexp ctx, sexp stack, sexp env) { sexp_gc_var(ctx, res, save_res); if (ctx) sexp_gc_preserve(ctx, res, save_res); res = sexp_alloc_type(ctx, context, SEXP_CONTEXT); if ((! stack) || (stack == SEXP_FALSE)) { - stack = sexp_alloc_tagged(ctx, sexp_sizeof(stack)+sizeof(sexp)*INIT_STACK_SIZE, SEXP_STACK); + stack = sexp_alloc_tagged(ctx, SEXP_STACK_SIZE, SEXP_STACK); sexp_stack_length(stack) = INIT_STACK_SIZE; sexp_stack_top(stack) = 0; } @@ -354,14 +356,6 @@ static sexp sexp_compile_error(sexp ctx, char *message, sexp obj) { return exn; } -#define analyze_check_exception(x) do {if (sexp_exceptionp(x)) \ - return (x); \ - } while (0) - -#define analyze_bind(var, x, ctx) do {(var) = analyze(ctx, x); \ - analyze_check_exception(var); \ - } while (0) - static sexp analyze_app (sexp ctx, sexp x) { sexp_gc_var(ctx, res, s_res); sexp_gc_var(ctx, tmp, s_tmp); @@ -429,20 +423,27 @@ static sexp analyze_set (sexp ctx, sexp x) { sexp_gc_var(ctx, value, s_value); sexp_gc_preserve(ctx, ref, s_ref); sexp_gc_preserve(ctx, value, s_value); - ref = analyze_var_ref(ctx, sexp_cadr(x)); - if (sexp_lambdap(sexp_ref_loc(ref))) - sexp_insert(ctx, sexp_lambda_sv(sexp_ref_loc(ref)), sexp_ref_name(ref)); - value = analyze(ctx, sexp_caddr(x)); - if (sexp_exceptionp(ref)) - res = ref; - else if (sexp_exceptionp(value)) - res = value; - else - res = sexp_make_set(ctx, ref, value); + if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)) + && sexp_nullp(sexp_cdddr(x)) && sexp_idp(sexp_cadr(x)))) { + res = sexp_compile_error(ctx, "bad set! syntax", x); + } else { + ref = analyze_var_ref(ctx, sexp_cadr(x)); + if (sexp_lambdap(sexp_ref_loc(ref))) + sexp_insert(ctx, sexp_lambda_sv(sexp_ref_loc(ref)), sexp_ref_name(ref)); + value = analyze(ctx, sexp_caddr(x)); + if (sexp_exceptionp(ref)) + res = ref; + else if (sexp_exceptionp(value)) + res = value; + else + res = sexp_make_set(ctx, ref, value); + } sexp_gc_release(ctx, ref, s_ref); return res; } +#define sexp_return(res, val) do {res=val; goto cleanup;} while (0) + static sexp analyze_lambda (sexp ctx, sexp x) { sexp name, ls; sexp_gc_var(ctx, res, s_res); @@ -457,14 +458,14 @@ static sexp analyze_lambda (sexp ctx, sexp x) { sexp_gc_preserve(ctx, value, s_value); sexp_gc_preserve(ctx, defs, s_defs); sexp_gc_preserve(ctx, ctx2, s_ctx2); - /* verify syntax - XXXX release! */ + /* verify syntax */ if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) - return sexp_compile_error(ctx, "bad lambda syntax", x); + sexp_return(res, sexp_compile_error(ctx, "bad lambda syntax", x)); for (ls=sexp_cadr(x); sexp_pairp(ls); ls=sexp_cdr(ls)) if (! sexp_idp(sexp_car(ls))) - return sexp_compile_error(ctx, "non-symbol parameter", x); + sexp_return(res, sexp_compile_error(ctx, "non-symbol parameter", x)); else if (sexp_memq(ctx, sexp_car(ls), sexp_cdr(ls)) != SEXP_FALSE) - return sexp_compile_error(ctx, "duplicate parameter", x); + sexp_return(res, sexp_compile_error(ctx, "duplicate parameter", x)); /* build lambda and analyze body */ res = sexp_make_lambda(ctx, sexp_cadr(x)); ctx2 = sexp_make_child_context(ctx, res); @@ -472,7 +473,7 @@ static sexp analyze_lambda (sexp ctx, sexp x) { sexp_context_env(ctx2) = extend_env(ctx2, sexp_context_env(ctx2), tmp, res); sexp_env_lambda(sexp_context_env(ctx2)) = res; body = analyze_seq(ctx2, sexp_cddr(x)); - analyze_check_exception(body); + if (sexp_exceptionp(body)) sexp_return(res, body); /* delayed analyze internal defines */ defs = SEXP_NULL; for (ls=sexp_lambda_defs(res); sexp_pairp(ls); ls=sexp_cdr(ls)) { @@ -485,7 +486,7 @@ static sexp analyze_lambda (sexp ctx, sexp x) { name = sexp_cadr(tmp); value = analyze(ctx2, sexp_caddr(tmp)); } - analyze_check_exception(value); + if (sexp_exceptionp(value)) sexp_return(res, value); sexp_push(ctx2, defs, sexp_make_set(ctx2, analyze_var_ref(ctx2, name), value)); } @@ -498,6 +499,7 @@ static sexp analyze_lambda (sexp ctx, sexp x) { sexp_seq_ls(body) = sexp_append2(ctx2, defs, sexp_seq_ls(body)); } sexp_lambda_body(res) = body; + cleanup: sexp_gc_release(ctx, res, s_res); return res; } @@ -510,11 +512,16 @@ static sexp analyze_if (sexp ctx, sexp x) { sexp_gc_preserve(ctx, test, s_test); sexp_gc_preserve(ctx, pass, s_pass); sexp_gc_preserve(ctx, fail, s_fail); - analyze_bind(test, sexp_cadr(x), ctx); - analyze_bind(pass, sexp_caddr(x), ctx); - fail_expr = sexp_pairp(sexp_cdddr(x)) ? sexp_cadddr(x) : SEXP_VOID; - analyze_bind(fail, fail_expr, ctx); - res = sexp_make_cnd(ctx, test, pass, fail); + if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) { + res = sexp_compile_error(ctx, "bad if syntax", x); + } else { + test = analyze(ctx, sexp_cadr(x)); + pass = analyze(ctx, sexp_caddr(x)); + fail_expr = sexp_pairp(sexp_cdddr(x)) ? sexp_cadddr(x) : SEXP_VOID; + fail = analyze(ctx, fail_expr); + res = (sexp_exceptionp(test) ? test : sexp_exceptionp(pass) ? pass : + sexp_exceptionp(fail) ? fail : sexp_make_cnd(ctx, test, pass, fail)); + } sexp_gc_release(ctx, test, s_test); return res; } @@ -530,35 +537,40 @@ static sexp analyze_define (sexp ctx, sexp x) { sexp_gc_preserve(ctx, tmp, s_tmp); sexp_gc_preserve(ctx, env, s_env); env = sexp_context_env(ctx); - name = (sexp_pairp(sexp_cadr(x)) ? sexp_caadr(x) : sexp_cadr(x)); - if (sexp_env_lambda(env) && sexp_lambdap(sexp_env_lambda(env))) { - tmp = sexp_cons(ctx, name, sexp_context_lambda(ctx)); - sexp_push(ctx, sexp_env_bindings(env), tmp); - sexp_push(ctx, sexp_lambda_sv(sexp_env_lambda(env)), name); - sexp_push(ctx, sexp_lambda_locals(sexp_env_lambda(env)), name); - sexp_push(ctx, sexp_lambda_defs(sexp_env_lambda(env)), x); - res = SEXP_VOID; + if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) { + res = sexp_compile_error(ctx, "bad define syntax", x); } else { - env_cell_create(ctx, env, name, SEXP_VOID); - if (sexp_pairp(sexp_cadr(x))) { - tmp = sexp_cons(ctx, sexp_cdadr(x), sexp_cddr(x)); - tmp = sexp_cons(ctx, SEXP_VOID, tmp); - value = analyze_lambda(ctx, tmp); - } else - value = analyze(ctx, sexp_caddr(x)); - ref = analyze_var_ref(ctx, name); - if (sexp_exceptionp(ref)) - res = ref; - else if (sexp_exceptionp(value)) - res = value; - else - res = sexp_make_set(ctx, ref, value); + name = (sexp_pairp(sexp_cadr(x)) ? sexp_caadr(x) : sexp_cadr(x)); + if (sexp_env_lambda(env) && sexp_lambdap(sexp_env_lambda(env))) { + tmp = sexp_cons(ctx, name, sexp_context_lambda(ctx)); + sexp_push(ctx, sexp_env_bindings(env), tmp); + sexp_push(ctx, sexp_lambda_sv(sexp_env_lambda(env)), name); + sexp_push(ctx, sexp_lambda_locals(sexp_env_lambda(env)), name); + sexp_push(ctx, sexp_lambda_defs(sexp_env_lambda(env)), x); + res = SEXP_VOID; + } else { + env_cell_create(ctx, env, name, SEXP_VOID); + if (sexp_pairp(sexp_cadr(x))) { + tmp = sexp_cons(ctx, sexp_cdadr(x), sexp_cddr(x)); + tmp = sexp_cons(ctx, SEXP_VOID, tmp); + value = analyze_lambda(ctx, tmp); + } else + value = analyze(ctx, sexp_caddr(x)); + ref = analyze_var_ref(ctx, name); + if (sexp_exceptionp(ref)) + res = ref; + else if (sexp_exceptionp(value)) + res = value; + else + res = sexp_make_set(ctx, ref, value); + } } sexp_gc_release(ctx, ref, s_ref); return res; } static sexp analyze_bind_syntax (sexp ls, sexp eval_ctx, sexp bind_ctx) { + sexp res = SEXP_VOID; sexp_gc_var(eval_ctx, proc, s_proc); sexp_gc_var(eval_ctx, mac, s_mac); sexp_gc_var(eval_ctx, tmp, s_tmp); @@ -566,16 +578,23 @@ static sexp analyze_bind_syntax (sexp ls, sexp eval_ctx, sexp bind_ctx) { sexp_gc_preserve(eval_ctx, mac, s_mac); sexp_gc_preserve(eval_ctx, tmp, s_tmp); for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) { - proc = eval_in_context(eval_ctx, sexp_cadar(ls)); - analyze_check_exception(proc); - if (sexp_procedurep(proc)) { - mac = sexp_make_macro(eval_ctx, proc, sexp_context_env(eval_ctx)); - tmp = sexp_cons(eval_ctx, sexp_caar(ls), mac); - sexp_push(eval_ctx, sexp_env_bindings(sexp_context_env(bind_ctx)), tmp); + if (! (sexp_pairp(sexp_car(ls)) && sexp_pairp(sexp_cdar(ls)) + && sexp_nullp(sexp_cddar(ls)))) { + res = sexp_compile_error(eval_ctx, "bad syntax binding", sexp_car(ls)); + } else { + proc = eval_in_context(eval_ctx, sexp_cadar(ls)); + if (sexp_exceptionp(proc)) { + res = proc; + break; + } else if (sexp_procedurep(proc)) { + mac = sexp_make_macro(eval_ctx, proc, sexp_context_env(eval_ctx)); + tmp = sexp_cons(eval_ctx, sexp_caar(ls), mac); + sexp_push(eval_ctx, sexp_env_bindings(sexp_context_env(bind_ctx)), tmp); + } } } sexp_gc_release(eval_ctx, proc, s_proc); - return SEXP_VOID; + return res; } static sexp analyze_define_syntax (sexp ctx, sexp x) { @@ -596,14 +615,17 @@ static sexp analyze_let_syntax (sexp ctx, sexp x) { sexp_gc_preserve(ctx, env, s_env); sexp_gc_preserve(ctx, ctx2, s_ctx2); sexp_gc_preserve(ctx, tmp, s_tmp); - env = sexp_alloc_type(ctx, env, SEXP_ENV); - sexp_env_parent(env) = sexp_env_parent(sexp_context_env(ctx)); - sexp_env_bindings(env) = sexp_env_bindings(sexp_context_env(ctx)); - ctx2 = sexp_make_child_context(ctx, sexp_context_lambda(ctx)); - sexp_context_env(ctx2) = env; - tmp = analyze_bind_syntax(sexp_cadr(x), ctx, ctx2); - analyze_check_exception(tmp); - res = analyze_seq(ctx2, sexp_cddr(x)); + if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) { + res = sexp_compile_error(ctx, "bad let-syntax", x); + } else { + env = sexp_alloc_type(ctx, env, SEXP_ENV); + sexp_env_parent(env) = sexp_env_parent(sexp_context_env(ctx)); + sexp_env_bindings(env) = sexp_env_bindings(sexp_context_env(ctx)); + ctx2 = sexp_make_child_context(ctx, sexp_context_lambda(ctx)); + sexp_context_env(ctx2) = env; + tmp = analyze_bind_syntax(sexp_cadr(x), ctx, ctx2); + res = (sexp_exceptionp(tmp) ? tmp : analyze_seq(ctx2, sexp_cddr(x))); + } sexp_gc_release(ctx, env, s_env); return res; } @@ -612,8 +634,12 @@ static sexp analyze_letrec_syntax (sexp ctx, sexp x) { sexp res; sexp_gc_var(ctx, tmp, s_tmp); sexp_gc_preserve(ctx, tmp, s_tmp); - tmp = analyze_bind_syntax(sexp_cadr(x), ctx, ctx); - res = (sexp_exceptionp(tmp) ? tmp : analyze_seq(ctx, sexp_cddr(x))); + if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) { + res = sexp_compile_error(ctx, "bad letrec-syntax", x); + } else { + tmp = analyze_bind_syntax(sexp_cadr(x), ctx, ctx); + res = (sexp_exceptionp(tmp) ? tmp : analyze_seq(ctx, sexp_cddr(x))); + } sexp_gc_release(ctx, tmp, s_tmp); return res; } @@ -685,8 +711,8 @@ static sexp analyze (sexp ctx, sexp object) { res = sexp_compile_error(ctx, "too many args for opcode", x); } else { res = analyze_app(ctx, sexp_cdr(x)); - analyze_check_exception(res); - sexp_push(ctx, res, op); + if (! sexp_exceptionp(res)) + sexp_push(ctx, res, op); } } else { res = analyze_app(ctx, x); @@ -2031,15 +2057,19 @@ sexp compile (sexp ctx, sexp x) { sexp_gc_preserve(ctx, ctx2, s_ctx2); sexp_gc_preserve(ctx, vec, s_vec); sexp_gc_preserve(ctx, res, s_res); - analyze_bind(ast, x, ctx); - free_vars(ctx, ast, SEXP_NULL); /* should return SEXP_NULL */ - ctx2 = sexp_make_context(ctx, sexp_context_stack(ctx), sexp_context_env(ctx)); - sexp_context_parent(ctx2) = ctx; - generate(ctx2, ast); - res = finalize_bytecode(ctx2); - vec = sexp_make_vector(ctx, 0, SEXP_VOID); - res = sexp_make_procedure(ctx, sexp_make_integer(0), sexp_make_integer(0), - res, vec); + ast = analyze(ctx, x); + if (sexp_exceptionp(ast)) { + res = ast; + } else { + free_vars(ctx, ast, SEXP_NULL); /* should return SEXP_NULL */ + ctx2 = sexp_make_context(ctx,sexp_context_stack(ctx),sexp_context_env(ctx)); + sexp_context_parent(ctx2) = ctx; + generate(ctx2, ast); + res = finalize_bytecode(ctx2); + vec = sexp_make_vector(ctx, 0, SEXP_VOID); + res = sexp_make_procedure(ctx, sexp_make_integer(0), sexp_make_integer(0), + res, vec); + } sexp_gc_release(ctx, ast, s_ast); return res; } diff --git a/gc.c b/gc.c index 0f5c63d7..2770f575 100644 --- a/gc.c +++ b/gc.c @@ -4,9 +4,11 @@ #include "sexp.h" -#define SEXP_INITIAL_HEAP_SIZE (2*1024*1024) +/* #define SEXP_INITIAL_HEAP_SIZE (2*1024*1024) */ +#define SEXP_INITIAL_HEAP_SIZE 37000 #define SEXP_MAXIMUM_HEAP_SIZE 0 #define SEXP_MINIMUM_OBJECT_SIZE (sexp_sizeof(flonum)) +#define SEXP_GROW_HEAP_RATIO 0.8 typedef struct sexp_heap *sexp_heap; @@ -21,6 +23,11 @@ static sexp_heap heap; static sexp* stack_base; extern sexp continuation_resumer, final_resumer; +static sexp_heap sexp_heap_last (sexp_heap h) { + while (h->next) h = h->next; + return h; +} + sexp_uint_t sexp_allocated_bytes (sexp x) { sexp_uint_t res, *len_ptr; sexp t; @@ -57,7 +64,7 @@ void sexp_mark (sexp x) { } } -#ifdef USE_DEBUG_GC +#if USE_DEBUG_GC int stack_references_pointer_p (sexp ctx, sexp x) { sexp *p; for (p=&x; pnext; h=h->next) - ; + sexp_heap h = sexp_heap_last(heap); cur_size = h->size; new_size = sexp_align(((cur_size > size) ? cur_size : size) * 2, 4); h->next = sexp_make_heap(new_size); @@ -200,17 +205,20 @@ void* sexp_try_alloc (sexp ctx, size_t size) { void* sexp_alloc (sexp ctx, size_t size) { void *res; + size_t freed; + sexp_heap h; size = sexp_align(size, 4); res = sexp_try_alloc(ctx, size); if (! res) { - if (sexp_unbox_integer(sexp_gc(ctx)) >= size) - res = sexp_try_alloc(ctx, size); - if ((! res) && sexp_grow_heap(ctx, size)) - res = sexp_try_alloc(ctx, size); + freed = sexp_unbox_integer(sexp_gc(ctx)); + h = sexp_heap_last(heap); + if (((freed < size) + || ((h->size - freed) < h->size*(1 - SEXP_GROW_HEAP_RATIO))) + && ((! SEXP_MAXIMUM_HEAP_SIZE) || (size < SEXP_MAXIMUM_HEAP_SIZE))) + sexp_grow_heap(ctx, size); + res = sexp_try_alloc(ctx, size); if (! res) { - fprintf(stderr, - "chibi: out of memory trying to allocate %ld bytes, aborting\n", - size); + fprintf(stderr, "out of memory allocating %ld bytes, aborting\n", size); exit(70); } } @@ -220,6 +228,7 @@ void* sexp_alloc (sexp ctx, size_t size) { void sexp_gc_init () { sexp_uint_t size = sexp_align(SEXP_INITIAL_HEAP_SIZE, 4); heap = sexp_make_heap(size); + /* the +32 is a hack, but this is just for debugging anyway */ stack_base = ((sexp*)&size) + 32; } diff --git a/sexp-huff.c b/opt/sexp-huff.c similarity index 100% rename from sexp-huff.c rename to opt/sexp-huff.c diff --git a/sexp-hufftabs.c b/opt/sexp-hufftabs.c similarity index 100% rename from sexp-hufftabs.c rename to opt/sexp-hufftabs.c diff --git a/sexp-unhuff.c b/opt/sexp-unhuff.c similarity index 100% rename from sexp-unhuff.c rename to opt/sexp-unhuff.c diff --git a/sexp.c b/sexp.c index 79269495..87bf0e6b 100644 --- a/sexp.c +++ b/sexp.c @@ -10,9 +10,9 @@ struct huff_entry { unsigned char len; unsigned short bits; }; -#include "sexp-hufftabs.c" +#include "opt/sexp-hufftabs.c" static struct huff_entry huff_table[] = { -#include "sexp-huff.c" +#include "opt/sexp-huff.c" }; #endif @@ -41,7 +41,6 @@ static int digit_value (c) { } static int is_separator(int c) { - /* return (!((c-9)&(~3))) | (~(c^4)); */ return 0>3; while (c) { -#include "sexp-unhuff.c" +#include "opt/sexp-unhuff.c" sexp_write_char(res, out); } } @@ -1119,7 +1111,6 @@ sexp sexp_read_raw (sexp ctx, sexp in) { res = sexp_read(ctx, in); if (sexp_listp(ctx, res) == SEXP_FALSE) { if (! sexp_exceptionp(res)) { - sexp_deep_free(ctx, res); res = sexp_read_error(ctx, "dotted list not allowed in vector syntax", SEXP_NULL, in); @@ -1192,11 +1183,15 @@ sexp sexp_read (sexp ctx, sexp in) { #if USE_STRING_STREAMS sexp sexp_read_from_string(sexp ctx, char *str) { - sexp s = sexp_c_string(ctx, str, -1); - sexp in = sexp_make_input_string_port(ctx, s); - sexp res = sexp_read(ctx, in); - sexp_free(ctx, s); - sexp_deep_free(ctx, in); + sexp res; + sexp_gc_var(ctx, s, s_s); + sexp_gc_var(ctx, in, s_in); + sexp_gc_preserve(ctx, s, s_s); + sexp_gc_preserve(ctx, in, s_in); + s = sexp_c_string(ctx, str, -1); + in = sexp_make_input_string_port(ctx, s); + res = sexp_read(ctx, in); + sexp_gc_release(ctx, s, s_s); return res; } #endif diff --git a/sexp.h b/sexp.h index bded73f8..f713e0bd 100644 --- a/sexp.h +++ b/sexp.h @@ -426,6 +426,8 @@ void *sexp_realloc(sexp ctx, sexp x, size_t size); #define sexp_stack_top(x) ((x)->value.stack.top) #define sexp_stack_data(x) ((x)->value.stack.data) +#define sexp_context_heap(x) ((x)->value.context.heap) +#define sexp_context_symbols(x) ((x)->value.context.symbols) #define sexp_context_env(x) ((x)->value.context.env) #define sexp_context_stack(x) ((x)->value.context.stack) #define sexp_context_depth(x) ((x)->value.context.depth) From 8a8e7c165efdd4f6853b59cc58a3517274e85c35 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 18 Jun 2009 00:49:59 +0900 Subject: [PATCH 124/154] preparing for 0.2 release --- Makefile | 2 +- README | 8 ++------ 2 files changed, 3 insertions(+), 7 deletions(-) diff --git a/Makefile b/Makefile index ccf712fb..6c28e271 100644 --- a/Makefile +++ b/Makefile @@ -12,7 +12,7 @@ MODDIR=$(PREFIX)/share/chibi-scheme LDFLAGS=-lm # -Oz for smaller size on darwin -CFLAGS=-Wall -O2 -g -save-temps +CFLAGS=-Wall -O2 -g #-save-temps ./gc/gc.a: ./gc/alloc.c cd gc && make diff --git a/README b/README index e4eb9abc..d5f2b369 100644 --- a/README +++ b/README @@ -4,10 +4,7 @@ Simple and Minimal Scheme Implementation - http://synthcode.com/scheme/chibi-scheme-0.1.tgz - - version 0.1 - April 8, 2009 + http://synthcode.com/wiki/chibi-scheme/ Chibi-Scheme is a very small but mostly complete R5RS Scheme @@ -16,8 +13,7 @@ as much as possible not to trade its small size by cutting corners, and provides full continuations, both low and high-level hygienic macros based on syntactic-closures, string ports and exceptions. Chibi-Scheme is written in highly portable C and supports multiple -simultaneous VM instances to run. Currently Chibi-Scheme uses the -Boehm conservative garbage collector to try to play well with C code. +simultaneous VM instances to run. To build, just run "make". You can edit the file config.h for a number of settings, mostly disabling features to make the executable From 9e6a0c1300e12c37871c8c254b029ccfeb52d9f1 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 18 Jun 2009 16:15:56 +0900 Subject: [PATCH 125/154] adding immediate flonum support --- config.h | 3 +++ debug.c | 2 ++ defaults.h | 4 ++++ eval.c | 2 +- gc.c | 18 +++++++++--------- sexp.c | 34 +++++++++++++++++++++++++++++++--- sexp.h | 24 ++++++++++++++++++------ 7 files changed, 68 insertions(+), 19 deletions(-) diff --git a/config.h b/config.h index 4b254b17..84ee7941 100644 --- a/config.h +++ b/config.h @@ -14,6 +14,9 @@ /* uncomment this if you only want fixnum support */ /* #define USE_FLONUMS 0 */ +/* uncomment this if you want immediate flonums */ +#define USE_IMMEDIATE_FLONUMS 1 + /* uncomment this if you don't need extended math operations */ /* #define USE_MATH 0 */ diff --git a/debug.c b/debug.c index cd329db9..8a03a8a8 100644 --- a/debug.c +++ b/debug.c @@ -62,6 +62,7 @@ static sexp sexp_disasm (sexp ctx, sexp bc, sexp out) { return SEXP_VOID; } +#ifdef DEBUG_VM static void sexp_print_stack (sexp *stack, int top, int fp, sexp out) { int i; for (i=0; i SEXP_CONTEXT)) - return sexp_align(1, 4); + return sexp_heap_align(1); t = &(sexp_types[sexp_pointer_tag(x)]); len_ptr = (sexp_uint_t*) (((char*)x) + sexp_type_size_off(t)); res = sexp_type_size_base(t) + len_ptr[0] * sexp_type_size_scale(t); @@ -83,7 +83,7 @@ sexp sexp_sweep (sexp ctx) { char *end; /* scan over the whole heap */ for ( ; h; h=h->next) { - p = (sexp) (h->data + sexp_align(sexp_sizeof(pair), 4)); + p = (sexp) (h->data + sexp_heap_align(sexp_sizeof(pair))); q = h->free_list; end = (char*)h->data + h->size; while (((char*)p) < end) { @@ -94,7 +94,7 @@ sexp sexp_sweep (sexp ctx) { p = (sexp) (((char*)p) + (sexp_uint_t)sexp_car(p)); continue; } - size = sexp_align(sexp_allocated_bytes(p), 4); + size = sexp_heap_align(sexp_allocated_bytes(p)); if ((! sexp_gc_mark(p)) && (! stack_references_pointer_p(ctx, p))) { sum_freed += size; if (((((char*)q)+(sexp_uint_t)sexp_car(q)) == (char*)p) @@ -153,15 +153,15 @@ sexp_heap sexp_make_heap (size_t size) { sexp_heap h = (sexp_heap) malloc(sizeof(struct sexp_heap) + size); if (h) { h->size = size; - h->data = (char*) sexp_align((sexp_uint_t)&(h->data), 4); + h->data = (char*) sexp_heap_align((sexp_uint_t)&(h->data)); free = h->free_list = (sexp) h->data; h->next = NULL; - next = (sexp) ((char*)free + sexp_align(sexp_sizeof(pair), 4)); + next = (sexp) ((char*)free + sexp_heap_align(sexp_sizeof(pair))); sexp_pointer_tag(free) = SEXP_PAIR; sexp_car(free) = 0; /* actually sexp_sizeof(pair) */ sexp_cdr(free) = next; sexp_pointer_tag(next) = SEXP_PAIR; - sexp_car(next) = (sexp) (size - sexp_align(sexp_sizeof(pair), 4)); + sexp_car(next) = (sexp) (size - sexp_heap_align(sexp_sizeof(pair))); sexp_cdr(next) = SEXP_NULL; } return h; @@ -171,7 +171,7 @@ int sexp_grow_heap (sexp ctx, size_t size) { size_t cur_size, new_size; sexp_heap h = sexp_heap_last(heap); cur_size = h->size; - new_size = sexp_align(((cur_size > size) ? cur_size : size) * 2, 4); + new_size = sexp_heap_align(((cur_size > size) ? cur_size : size) * 2); h->next = sexp_make_heap(new_size); return (h->next != NULL); } @@ -207,7 +207,7 @@ void* sexp_alloc (sexp ctx, size_t size) { void *res; size_t freed; sexp_heap h; - size = sexp_align(size, 4); + size = sexp_heap_align(size); res = sexp_try_alloc(ctx, size); if (! res) { freed = sexp_unbox_integer(sexp_gc(ctx)); @@ -226,7 +226,7 @@ void* sexp_alloc (sexp ctx, size_t size) { } void sexp_gc_init () { - sexp_uint_t size = sexp_align(SEXP_INITIAL_HEAP_SIZE, 4); + sexp_uint_t size = sexp_heap_align(SEXP_INITIAL_HEAP_SIZE); heap = sexp_make_heap(size); /* the +32 is a hack, but this is just for debugging anyway */ stack_base = ((sexp*)&size) + 32; diff --git a/sexp.c b/sexp.c index 87bf0e6b..69516f5f 100644 --- a/sexp.c +++ b/sexp.c @@ -5,7 +5,7 @@ #include "sexp.h" /* optional huffman-compressed immediate symbols */ -#ifdef USE_HUFF_SYMS +#if USE_HUFF_SYMS struct huff_entry { unsigned char len; unsigned short bits; @@ -326,6 +326,15 @@ sexp sexp_equalp (sexp ctx, sexp a, sexp b) { loop: if (a == b) return SEXP_TRUE; +#if USE_IMMEDIATE_FLONUMS + if ((! sexp_pointerp(a)) || (! sexp_pointerp(b))) + return + sexp_make_boolean((a == b) + || (sexp_flonump(a) + && sexp_make_integer(sexp_flonum_value(a)) == b) + || (sexp_flonump(b) + && sexp_make_integer(sexp_flonum_value(b)) == a)); +#else if (! sexp_pointerp(a)) return sexp_make_boolean(sexp_integerp(a) && sexp_pointerp(b) && (sexp_unbox_integer(a) @@ -334,6 +343,7 @@ sexp sexp_equalp (sexp ctx, sexp a, sexp b) { return sexp_make_boolean(sexp_integerp(b) && sexp_pointerp(a) && (sexp_unbox_integer(b) == sexp_flonum_value(a))); +#endif if (sexp_pointer_tag(a) != sexp_pointer_tag(b)) return SEXP_FALSE; switch (sexp_pointer_tag(a)) { @@ -358,8 +368,10 @@ sexp sexp_equalp (sexp ctx, sexp a, sexp b) { && (! strncmp(sexp_string_data(a), sexp_string_data(b), sexp_string_length(a)))); +#if ! USE_IMMEDIATE_FLONUMS case SEXP_FLONUM: return sexp_make_boolean(sexp_flonum_value(a) == sexp_flonum_value(b)); +#endif default: return SEXP_FALSE; } @@ -367,11 +379,13 @@ sexp sexp_equalp (sexp ctx, sexp a, sexp b) { /********************* strings, symbols, vectors **********************/ +#if ! USE_IMMEDIATE_FLONUMS sexp sexp_make_flonum(sexp ctx, double f) { sexp x = sexp_alloc_type(ctx, flonum, SEXP_FLONUM); sexp_flonum_value(x) = f; return x; } +#endif sexp sexp_make_string(sexp ctx, sexp len, sexp ch) { sexp_sint_t clen = sexp_unbox_integer(len); @@ -780,6 +794,11 @@ void sexp_write (sexp obj, sexp out) { } } else if (sexp_integerp(obj)) { sexp_printf(out, "%ld", sexp_unbox_integer(obj)); +#if USE_IMMEDIATE_FLONUMS + } else if (sexp_flonump(obj)) { + f = sexp_flonum_value(obj); + sexp_printf(out, "%.15g%s", f, (f == trunc(f)) ? ".0" : ""); +#endif } else if (sexp_charp(obj)) { if (obj == sexp_make_character(' ')) sexp_write_string("#\\space", out); @@ -933,7 +952,12 @@ sexp sexp_read_number(sexp ctx, sexp in, int base) { if ((c!='.') && (sexp_flonum_value(f) == round(sexp_flonum_value(f)))) { res = (sexp_sint_t) sexp_flonum_value(f); } else { - if (negativep) sexp_flonum_value(f) = -sexp_flonum_value(f); + if (negativep) +#if USE_IMMEDIATE_FLONUMS + f = sexp_make_flonum(ctx, -sexp_flonum_value(f)); +#else + sexp_flonum_value(f) = -sexp_flonum_value(f); +#endif return f; } } else { @@ -1146,9 +1170,13 @@ sexp sexp_read_raw (sexp ctx, sexp in) { sexp_push_char(c2, in); res = sexp_read_number(ctx, in, 10); if ((c1 == '-') && ! sexp_exceptionp(res)) { -#ifdef USE_FLONUMS +#if USE_FLONUMS if (sexp_flonump(res)) +#if USE_IMMEDIATE_FLONUMS + res = sexp_make_flonum(ctx, -1 * sexp_flonum_value(res)); +#else sexp_flonum_value(res) = -1 * sexp_flonum_value(res); +#endif else #endif res = sexp_fx_mul(res, -1); diff --git a/sexp.h b/sexp.h index f713e0bd..4e3dd368 100644 --- a/sexp.h +++ b/sexp.h @@ -21,8 +21,8 @@ /* tagging system * bits end in 00: pointer * 01: fixnum - * 011: - * 111: immediate symbol + * 011: immediate flonum (optional) + * 111: immediate symbol (optional) * 0110: char * 1110: other immediate object (NULL, TRUE, FALSE) */ @@ -38,6 +38,7 @@ #define SEXP_POINTER_TAG 0 #define SEXP_FIXNUM_TAG 1 #define SEXP_ISYMBOL_TAG 7 +#define SEXP_IFLONUM_TAG 3 #define SEXP_CHAR_TAG 6 #define SEXP_EXTENDED_TAG 14 @@ -256,6 +257,7 @@ void *sexp_realloc(sexp ctx, sexp x, size_t size); #endif #define sexp_align(n, bits) (((n)+(1<<(bits))-1)&(((sexp_uint_t)-1)-((1<<(bits))-1))) +#define sexp_heap_align(n) sexp_align(n, 4) #define sexp_sizeof(x) (offsetof(struct sexp_struct, value) \ + sizeof(((sexp)0)->value.x)) @@ -280,12 +282,25 @@ void *sexp_realloc(sexp ctx, sexp x, size_t size); #define sexp_check_tag(x,t) (sexp_pointerp(x) && (sexp_pointer_tag(x) == (t))) +#if USE_IMMEDIATE_FLONUMS +union sexp_flonum_conv { + float flonum; + sexp_uint_t bits; +}; +#define sexp_flonump(x) (((sexp_uint_t)(x) & SEXP_IMMEDIATE_MASK) == SEXP_IFLONUM_TAG) +#define sexp_make_flonum(ctx, x) ((sexp) ((((union sexp_flonum_conv)((float)(x))).bits & ~SEXP_IMMEDIATE_MASK) + SEXP_IFLONUM_TAG)) +#define sexp_flonum_value(x) (((union sexp_flonum_conv)(((sexp_uint_t)(x)) & ~SEXP_IMMEDIATE_MASK)).flonum) +#else +#define sexp_flonump(x) (sexp_check_tag(x, SEXP_FLONUM)) +#define sexp_flonum_value(f) ((f)->value.flonum) +sexp sexp_make_flonum(sexp ctx, double f); +#endif + #define sexp_typep(x) (sexp_check_tag(x, SEXP_TYPE)) #define sexp_pairp(x) (sexp_check_tag(x, SEXP_PAIR)) #define sexp_stringp(x) (sexp_check_tag(x, SEXP_STRING)) #define sexp_lsymbolp(x) (sexp_check_tag(x, SEXP_SYMBOL)) #define sexp_vectorp(x) (sexp_check_tag(x, SEXP_VECTOR)) -#define sexp_flonump(x) (sexp_check_tag(x, SEXP_FLONUM)) #define sexp_iportp(x) (sexp_check_tag(x, SEXP_IPORT)) #define sexp_oportp(x) (sexp_check_tag(x, SEXP_OPORT)) #define sexp_exceptionp(x) (sexp_check_tag(x, SEXP_EXCEPTION)) @@ -319,8 +334,6 @@ void *sexp_realloc(sexp ctx, sexp x, size_t size); #define sexp_make_character(n) ((sexp) ((((sexp_sint_t)n)<>SEXP_EXTENDED_BITS)) -#define sexp_flonum_value(f) ((f)->value.flonum) - #if USE_FLONUMS #define sexp_integer_to_flonum(ctx, x) (sexp_make_flonum(ctx, sexp_unbox_integer(x))) #else @@ -515,7 +528,6 @@ sexp sexp_length(sexp ctx, sexp ls); sexp sexp_c_string(sexp ctx, char *str, sexp_sint_t slen); sexp sexp_make_string(sexp ctx, sexp len, sexp ch); sexp sexp_substring (sexp ctx, sexp str, sexp start, sexp end); -sexp sexp_make_flonum(sexp ctx, double f); sexp sexp_intern(sexp ctx, char *str); sexp sexp_string_to_symbol(sexp ctx, sexp str); sexp sexp_make_vector(sexp ctx, sexp len, sexp dflt); From 56dcf497de4e3d052833df1e3c950b2f0710099b Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Fri, 19 Jun 2009 17:57:40 +0900 Subject: [PATCH 126/154] various fixes, gc can handle running the whole test suite in a loop hundreds of times. the heuristics for growing the heap still cause it to grow very slowly over time, but nonetheless slower than boehm. --- Makefile | 14 ++++------- config.h | 74 +++++++++++++++++++++++++++++++++++++++++++++++++++--- defaults.h | 70 --------------------------------------------------- eval.c | 50 +++++++++++++++++++++--------------- gc.c | 54 +++++++++++++++++++++------------------ sexp.c | 53 ++++++++++++++++++++------------------ sexp.h | 11 +++----- 7 files changed, 167 insertions(+), 159 deletions(-) delete mode 100644 defaults.h diff --git a/Makefile b/Makefile index 6c28e271..d5ae1e4f 100644 --- a/Makefile +++ b/Makefile @@ -9,21 +9,17 @@ LIBDIR=$(PREFIX)/lib INCDIR=$(PREFIX)/include/chibi-scheme MODDIR=$(PREFIX)/share/chibi-scheme -LDFLAGS=-lm +LDFLAGS=-lm #-lgc -L/opt/local/lib -# -Oz for smaller size on darwin -CFLAGS=-Wall -O2 -g #-save-temps +CFLAGS=-Wall -O2 -g #-I/opt/local/include #-save-temps -./gc/gc.a: ./gc/alloc.c - cd gc && make - -sexp.o: sexp.c gc.c sexp.h config.h defaults.h Makefile +sexp.o: sexp.c gc.c sexp.h config.h Makefile gcc -c $(CPPFLAGS) $(CFLAGS) -o $@ $< -eval.o: eval.c debug.c opcodes.c eval.h sexp.h config.h defaults.h Makefile +eval.o: eval.c debug.c opcodes.c eval.h sexp.h config.h Makefile gcc -c $(CPPFLAGS) $(CFLAGS) -o $@ $< -main.o: main.c eval.c debug.c opcodes.c eval.h sexp.h config.h defaults.h Makefile +main.o: main.c eval.c debug.c opcodes.c eval.h sexp.h config.h Makefile gcc -c $(CPPFLAGS) $(CFLAGS) -o $@ $< chibi-scheme: main.o sexp.o diff --git a/config.h b/config.h index 84ee7941..bb14e68b 100644 --- a/config.h +++ b/config.h @@ -14,8 +14,8 @@ /* uncomment this if you only want fixnum support */ /* #define USE_FLONUMS 0 */ -/* uncomment this if you want immediate flonums */ -#define USE_IMMEDIATE_FLONUMS 1 +/* uncomment this if you want immediate flonums (experimental) */ +/* #define USE_IMMEDIATE_FLONUMS 1 */ /* uncomment this if you don't need extended math operations */ /* #define USE_MATH 0 */ @@ -32,9 +32,75 @@ /* uncomment this to disable string ports */ /* #define USE_STRING_STREAMS 0 */ -/* uncomment this to disable a small optimization for let */ -/* #define USE_FAST_LET 0 */ +/* uncomment this to disable stack checks */ +/* #define USE_CHECK_STACK 0 */ /* uncomment this to enable debugging utilities */ /* #define USE_DEBUG 1 */ +/************************************************************************/ +/* DEFAULTS - DO NOT MODIFY ANYTHING BELOW THIS LINE */ +/************************************************************************/ + +#if HAVE_ERR_H +#include +#else +/* requires msg be a string literal, and at least one argument */ +#define errx(code, msg, ...) (fprintf(stderr,msg"\n",__VA_ARGS__), exit(code)) +#endif + +#if defined(__APPLE__) || defined(__FreeBSD__) || defined(__NetBSD__) || defined(__DragonFly__) || defined(__OpenBSD__) +#define SEXP_BSD 1 +#else +#define SEXP_BSD 0 +#define _GNU_SOURCE +#endif + +#ifndef USE_BOEHM +#define USE_BOEHM 0 +#endif + +#ifndef USE_MALLOC +#define USE_MALLOC 0 +#endif + +#ifndef USE_DEBUG_GC +#define USE_DEBUG_GC 0 +#endif + +#ifndef USE_FLONUMS +#define USE_FLONUMS 1 +#endif + +#ifndef USE_IMMEDIATE_FLONUMS +#define USE_IMMEDIATE_FLONUMS 0 +#endif + +#ifndef USE_MATH +#define USE_MATH 1 +#endif + +#ifndef USE_WARN_UNDEFS +#define USE_WARN_UNDEFS 1 +#endif + +#ifndef USE_HUFF_SYMS +#define USE_HUFF_SYMS 1 +#endif + +#ifndef USE_HASH_SYMS +#define USE_HASH_SYMS 1 +#endif + +#ifndef USE_DEBUG +#define USE_DEBUG 1 +#endif + +#ifndef USE_STRING_STREAMS +#define USE_STRING_STREAMS 1 +#endif + +#ifndef USE_CHECK_STACK +#define USE_CHECK_STACK 1 +#endif + diff --git a/defaults.h b/defaults.h deleted file mode 100644 index 7ac2d12b..00000000 --- a/defaults.h +++ /dev/null @@ -1,70 +0,0 @@ -/* defaults.h -- defaults for unspecified configs */ -/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ -/* BSD-style license: http://synthcode.com/license.txt */ - -#if HAVE_ERR_H -#include -#else -/* requires msg be a string literal, and at least one argument */ -#define errx(code, msg, ...) (fprintf(stderr,msg"\n",__VA_ARGS__), exit(code)) -#endif - -#if defined(__APPLE__) || defined(__FreeBSD__) || defined(__NetBSD__) || defined(__DragonFly__) || defined(__OpenBSD__) -#define SEXP_BSD 1 -#else -#define SEXP_BSD 0 -#define _GNU_SOURCE -#endif - -#ifndef USE_BOEHM -#define USE_BOEHM 0 -#endif - -#ifndef USE_MALLOC -#define USE_MALLOC 0 -#endif - -#ifndef USE_DEBUG_GC -#define USE_DEBUG_GC 0 -#endif - -#ifndef USE_FLONUMS -#define USE_FLONUMS 1 -#endif - -#ifndef USE_IMMEDIATE_FLONUMS -#define USE_IMMEDIATE_FLONUMS 0 -#endif - -#ifndef USE_MATH -#define USE_MATH 1 -#endif - -#ifndef USE_WARN_UNDEFS -#define USE_WARN_UNDEFS 1 -#endif - -#ifndef USE_HUFF_SYMS -#define USE_HUFF_SYMS 1 -#endif - -#ifndef USE_HASH_SYMS -#define USE_HASH_SYMS 1 -#endif - -#ifndef USE_DEBUG -#define USE_DEBUG 1 -#endif - -#ifndef USE_STRING_STREAMS -#define USE_STRING_STREAMS 1 -#endif - -#ifndef USE_FAST_LET -#define USE_FAST_LET 1 -#endif - -#ifndef USE_CHECK_STACK -#define USE_CHECK_STACK 0 -#endif - diff --git a/eval.c b/eval.c index e92178e7..e7515c46 100644 --- a/eval.c +++ b/eval.c @@ -1310,8 +1310,10 @@ sexp vm (sexp ctx, sexp proc) { goto make_call; case OP_CALL: #if USE_CHECK_STACK - if (top >= INIT_STACK_SIZE) - sexp_raise("out of stack space", SEXP_NULL); + if (top+16 >= INIT_STACK_SIZE) { + fprintf(stderr, "out of stack space\n"); + exit(70); + } #endif i = sexp_unbox_integer(_WORD0); tmp1 = _ARG1; @@ -1550,9 +1552,9 @@ sexp vm (sexp ctx, sexp proc) { else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) _ARG2 = sexp_fp_add(ctx, _ARG1, _ARG2); else if (sexp_flonump(_ARG1) && sexp_integerp(_ARG2)) - _ARG2 = sexp_fp_add(ctx, _ARG1, sexp_integer_to_flonum(ctx, _ARG2)); + _ARG2 = sexp_make_flonum(ctx, sexp_flonum_value(_ARG1) + (double)sexp_unbox_integer(_ARG2)); else if (sexp_integerp(_ARG1) && sexp_flonump(_ARG2)) - _ARG2 = sexp_fp_add(ctx, sexp_integer_to_flonum(ctx, _ARG1), _ARG2); + _ARG2 = sexp_make_flonum(ctx, (double)sexp_unbox_integer(_ARG1) + sexp_flonum_value(_ARG2)); #endif else sexp_raise("+: not a number", sexp_list2(ctx, _ARG1, _ARG2)); top--; @@ -1564,9 +1566,9 @@ sexp vm (sexp ctx, sexp proc) { else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) _ARG2 = sexp_fp_sub(ctx, _ARG1, _ARG2); else if (sexp_flonump(_ARG1) && sexp_integerp(_ARG2)) - _ARG2 = sexp_fp_sub(ctx, _ARG1, sexp_integer_to_flonum(ctx, _ARG2)); + _ARG2 = sexp_make_flonum(ctx, sexp_flonum_value(_ARG1) - (double)sexp_unbox_integer(_ARG2)); else if (sexp_integerp(_ARG1) && sexp_flonump(_ARG2)) - _ARG2 = sexp_fp_sub(ctx, sexp_integer_to_flonum(ctx, _ARG1), _ARG2); + _ARG2 = sexp_make_flonum(ctx, (double)sexp_unbox_integer(_ARG1) - sexp_flonum_value(_ARG2)); #endif else sexp_raise("-: not a number", sexp_list2(ctx, _ARG1, _ARG2)); top--; @@ -1578,9 +1580,9 @@ sexp vm (sexp ctx, sexp proc) { else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) _ARG2 = sexp_fp_mul(ctx, _ARG1, _ARG2); else if (sexp_flonump(_ARG1) && sexp_integerp(_ARG2)) - _ARG2 = sexp_fp_mul(ctx, _ARG1, sexp_integer_to_flonum(ctx, _ARG2)); + _ARG2 = sexp_make_flonum(ctx, sexp_flonum_value(_ARG1) * (double)sexp_unbox_integer(_ARG2)); else if (sexp_integerp(_ARG1) && sexp_flonump(_ARG2)) - _ARG2 = sexp_fp_mul(ctx, sexp_integer_to_flonum(ctx, _ARG1), _ARG2); + _ARG2 = sexp_make_flonum(ctx, (double)sexp_unbox_integer(_ARG1) * sexp_flonum_value(_ARG2)); #endif else sexp_raise("*: not a number", sexp_list2(ctx, _ARG1, _ARG2)); top--; @@ -1588,17 +1590,22 @@ sexp vm (sexp ctx, sexp proc) { case OP_DIV: if (_ARG2 == sexp_make_integer(0)) sexp_raise("divide by zero", SEXP_NULL); - if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) - _ARG2 = sexp_fp_div(ctx, - sexp_integer_to_flonum(ctx, _ARG1), - sexp_integer_to_flonum(ctx, _ARG2)); + if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) { +#if USE_FLONUMS + _ARG1 = sexp_integer_to_flonum(ctx, _ARG1); + _ARG2 = sexp_integer_to_flonum(ctx, _ARG2); + _ARG2 = sexp_fp_div(ctx, _ARG1, _ARG2); +#else + _ARG2 = sexp_fx_div(_ARG1, _ARG2); +#endif + } #if USE_FLONUMS else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) _ARG2 = sexp_fp_div(ctx, _ARG1, _ARG2); else if (sexp_flonump(_ARG1) && sexp_integerp(_ARG2)) - _ARG2 = sexp_fp_div(ctx, _ARG1, sexp_integer_to_flonum(ctx, _ARG2)); + _ARG2 = sexp_make_flonum(ctx, sexp_flonum_value(_ARG1) / (double)sexp_unbox_integer(_ARG2)); else if (sexp_integerp(_ARG1) && sexp_flonump(_ARG2)) - _ARG2 = sexp_fp_div(ctx, sexp_integer_to_flonum(ctx, _ARG1), _ARG2); + _ARG2 = sexp_make_flonum(ctx, (double)sexp_unbox_integer(_ARG1) / sexp_flonum_value(_ARG2)); #endif else sexp_raise("/: not a number", sexp_list2(ctx, _ARG1, _ARG2)); top--; @@ -1804,7 +1811,7 @@ static sexp sexp_open_input_file (sexp ctx, sexp path) { if (! in) return sexp_user_exception(ctx, SEXP_FALSE, "couldn't open input file", path); - return sexp_make_input_port(ctx, in, sexp_string_data(path)); + return sexp_make_input_port(ctx, in, path); } static sexp sexp_open_output_file (sexp ctx, sexp path) { @@ -1815,7 +1822,7 @@ static sexp sexp_open_output_file (sexp ctx, sexp path) { if (! out) return sexp_user_exception(ctx, SEXP_FALSE, "couldn't open output file", path); - return sexp_make_input_port(ctx, out, sexp_string_data(path)); + return sexp_make_input_port(ctx, out, path); } static sexp sexp_close_port (sexp ctx, sexp port) { @@ -1834,13 +1841,16 @@ static void sexp_warn_undefs (sexp from, sexp to, sexp out) { } sexp sexp_load (sexp ctx, sexp source, sexp env) { - sexp tmp, out, res=SEXP_VOID; + sexp tmp, out; sexp_gc_var(ctx, ctx2, s_ctx2); sexp_gc_var(ctx, x, s_x); sexp_gc_var(ctx, in, s_in); + sexp_gc_var(ctx, res, s_res); sexp_gc_preserve(ctx, ctx2, s_ctx2); sexp_gc_preserve(ctx, x, s_x); sexp_gc_preserve(ctx, in, s_in); + sexp_gc_preserve(ctx, res, s_res); + res = SEXP_VOID; in = sexp_open_input_file(ctx, source); out = env_global_ref(env, the_cur_err_symbol, SEXP_FALSE); ctx2 = sexp_make_context(ctx, NULL, env); @@ -2021,11 +2031,11 @@ static sexp sexp_make_standard_env (sexp ctx, sexp version) { env_define(ctx, e, sexp_intern(ctx, sexp_opcode_name(op)), op); } env_define(ctx, e, the_cur_in_symbol, - sexp_make_input_port(ctx, stdin, NULL)); + sexp_make_input_port(ctx, stdin, SEXP_FALSE)); env_define(ctx, e, the_cur_out_symbol, - sexp_make_output_port(ctx, stdout, NULL)); + sexp_make_output_port(ctx, stdout, SEXP_FALSE)); env_define(ctx, e, the_cur_err_symbol, - sexp_make_output_port(ctx, stderr, NULL)); + sexp_make_output_port(ctx, stderr, SEXP_FALSE)); env_define(ctx, e, the_interaction_env_symbol, e); sexp_gc_release(ctx, e, s_e); return e; diff --git a/gc.c b/gc.c index 3f0b0a06..f881ecd6 100644 --- a/gc.c +++ b/gc.c @@ -4,11 +4,12 @@ #include "sexp.h" -/* #define SEXP_INITIAL_HEAP_SIZE (2*1024*1024) */ -#define SEXP_INITIAL_HEAP_SIZE 37000 +#define SEXP_INITIAL_HEAP_SIZE (2*1024*1024) #define SEXP_MAXIMUM_HEAP_SIZE 0 -#define SEXP_MINIMUM_OBJECT_SIZE (sexp_sizeof(flonum)) -#define SEXP_GROW_HEAP_RATIO 0.8 +#define SEXP_MINIMUM_OBJECT_SIZE (sexp_sizeof(pair)) +#define SEXP_GROW_HEAP_RATIO 0.7 + +#define sexp_heap_align(n) sexp_align(n, 4) typedef struct sexp_heap *sexp_heap; @@ -67,7 +68,7 @@ void sexp_mark (sexp x) { #if USE_DEBUG_GC int stack_references_pointer_p (sexp ctx, sexp x) { sexp *p; - for (p=&x; psize = size; - h->data = (char*) sexp_heap_align((sexp_uint_t)&(h->data)); - free = h->free_list = (sexp) h->data; - h->next = NULL; - next = (sexp) ((char*)free + sexp_heap_align(sexp_sizeof(pair))); - sexp_pointer_tag(free) = SEXP_PAIR; - sexp_car(free) = 0; /* actually sexp_sizeof(pair) */ - sexp_cdr(free) = next; - sexp_pointer_tag(next) = SEXP_PAIR; - sexp_car(next) = (sexp) (size - sexp_heap_align(sexp_sizeof(pair))); - sexp_cdr(next) = SEXP_NULL; + if (! h) { + fprintf(stderr, "out of memory allocating %ld byte heap, aborting\n", size); + exit(70); } + h->size = size; + h->data = (char*) sexp_heap_align((sexp_uint_t)&(h->data)); + free = h->free_list = (sexp) h->data; + h->next = NULL; + next = (sexp) ((char*)free + sexp_heap_align(sexp_sizeof(pair))); + sexp_pointer_tag(free) = SEXP_PAIR; + sexp_car(free) = 0; /* actually sexp_sizeof(pair) */ + sexp_cdr(free) = next; + sexp_pointer_tag(next) = SEXP_PAIR; + sexp_car(next) = (sexp) (size - sexp_heap_align(sexp_sizeof(pair))); + sexp_cdr(next) = SEXP_NULL; return h; } @@ -205,15 +209,15 @@ void* sexp_try_alloc (sexp ctx, size_t size) { void* sexp_alloc (sexp ctx, size_t size) { void *res; - size_t freed; + size_t max_freed, sum_freed; sexp_heap h; size = sexp_heap_align(size); res = sexp_try_alloc(ctx, size); if (! res) { - freed = sexp_unbox_integer(sexp_gc(ctx)); + max_freed = sexp_unbox_integer(sexp_gc(ctx, &sum_freed)); h = sexp_heap_last(heap); - if (((freed < size) - || ((h->size - freed) < h->size*(1 - SEXP_GROW_HEAP_RATIO))) + if (((max_freed < size) + || ((h->size - sum_freed) < (h->size*(1 - SEXP_GROW_HEAP_RATIO)))) && ((! SEXP_MAXIMUM_HEAP_SIZE) || (size < SEXP_MAXIMUM_HEAP_SIZE))) sexp_grow_heap(ctx, size); res = sexp_try_alloc(ctx, size); diff --git a/sexp.c b/sexp.c index 69516f5f..ed8071ae 100644 --- a/sexp.c +++ b/sexp.c @@ -6,12 +6,12 @@ /* optional huffman-compressed immediate symbols */ #if USE_HUFF_SYMS -struct huff_entry { +struct sexp_huff_entry { unsigned char len; unsigned short bits; }; #include "opt/sexp-hufftabs.c" -static struct huff_entry huff_table[] = { +static struct sexp_huff_entry huff_table[] = { #include "opt/sexp-huff.c" }; #endif @@ -67,8 +67,8 @@ static struct sexp_struct sexp_types[] = { _DEF_TYPE(SEXP_VECTOR, sexp_offsetof(vector, data), 0, sexp_offsetof(vector, length), 1, sexp_sizeof(vector), sexp_offsetof(vector, length), 4, "vector"), _DEF_TYPE(SEXP_FLONUM, 0, 0, 0, 0, sexp_sizeof(flonum), 0, 0, "flonum"), _DEF_TYPE(SEXP_BIGNUM, 0, 0, 0, 0, sexp_sizeof(bignum), sexp_offsetof(bignum, length), 4, "bignum"), - _DEF_TYPE(SEXP_IPORT, sexp_offsetof(port, cookie), 1, 0, 0, sexp_sizeof(port), 0, 0, "input-port"), - _DEF_TYPE(SEXP_OPORT, sexp_offsetof(port, cookie), 1, 0, 0, sexp_sizeof(port), 0, 0, "output-port"), + _DEF_TYPE(SEXP_IPORT, sexp_offsetof(port, name), 2, 0, 0, sexp_sizeof(port), 0, 0, "input-port"), + _DEF_TYPE(SEXP_OPORT, sexp_offsetof(port, name), 2, 0, 0, sexp_sizeof(port), 0, 0, "output-port"), _DEF_TYPE(SEXP_EXCEPTION, sexp_offsetof(exception, kind), 6, 0, 0, sexp_sizeof(exception), 0, 0, "exception"), _DEF_TYPE(SEXP_PROCEDURE, sexp_offsetof(procedure, bc), 2, 0, 0, sexp_sizeof(procedure), 0, 0, "procedure"), _DEF_TYPE(SEXP_MACRO, sexp_offsetof(macro, proc), 2, 0, 0, sexp_sizeof(macro), 0, 0, "macro"), @@ -214,8 +214,7 @@ static sexp sexp_read_error (sexp ctx, char *msg, sexp irritants, sexp port) { sexp_gc_var(ctx, str, s_str); sexp_gc_preserve(ctx, name, s_name); sexp_gc_preserve(ctx, str, s_str); - name = (sexp_port_name(port) - ? sexp_c_string(ctx, sexp_port_name(port), -1) : SEXP_FALSE); + name = (sexp_port_name(port) ? sexp_port_name(port) : SEXP_FALSE); str = sexp_c_string(ctx, msg, -1); res = sexp_make_exception(ctx, the_read_error_symbol, str, irritants, SEXP_FALSE, name, @@ -402,7 +401,8 @@ sexp sexp_make_string(sexp ctx, sexp len, sexp ch) { sexp sexp_c_string(sexp ctx, char *str, sexp_sint_t slen) { sexp_sint_t len = ((slen >= 0) ? slen : strlen(str)); sexp s = sexp_make_string(ctx, sexp_make_integer(len), SEXP_VOID); - memcpy(sexp_string_data(s), str, len+1); + memcpy(sexp_string_data(s), str, len); + sexp_string_data(s)[len] = '\0'; return s; } @@ -425,7 +425,8 @@ sexp sexp_substring (sexp ctx, sexp str, sexp start, sexp end) { res = sexp_make_string(ctx, sexp_fx_sub(end, start), SEXP_VOID); memcpy(sexp_string_data(res), sexp_string_data(str)+sexp_unbox_integer(start), - sexp_string_length(res)+1); + sexp_string_length(res)); + sexp_string_data(res)[sexp_string_length(res)] = '\0'; return res; } @@ -442,7 +443,7 @@ static sexp_uint_t sexp_string_hash(char *str, sexp_uint_t acc) { #endif sexp sexp_intern(sexp ctx, char *str) { - struct huff_entry he; + struct sexp_huff_entry he; sexp_uint_t len, res=FNV_OFFSET_BASIS, space=3, newbits, bucket; char c, *p=str; sexp ls; @@ -529,9 +530,10 @@ sexp sexp_vector(sexp ctx, int count, ...) { #if SEXP_BSD -#define sexp_stream_buf(vec) sexp_vector_ref((sexp)vec, sexp_make_integer(0)) -#define sexp_stream_size(vec) sexp_vector_ref((sexp)vec, sexp_make_integer(1)) -#define sexp_stream_pos(vec) sexp_vector_ref((sexp)vec, sexp_make_integer(2)) +#define sexp_stream_ctx(vec) sexp_vector_ref((sexp)vec, sexp_make_integer(0)) +#define sexp_stream_buf(vec) sexp_vector_ref((sexp)vec, sexp_make_integer(1)) +#define sexp_stream_size(vec) sexp_vector_ref((sexp)vec, sexp_make_integer(2)) +#define sexp_stream_pos(vec) sexp_vector_ref((sexp)vec, sexp_make_integer(3)) int sstream_read (void *vec, char *dst, int n) { sexp_uint_t len = sexp_unbox_integer(sexp_stream_size(vec)); @@ -550,7 +552,9 @@ int sstream_write (void *vec, const char *src, int n) { pos = sexp_unbox_integer(sexp_stream_pos(vec)); newpos = pos+n; if (newpos >= len) { - newbuf = sexp_make_string(NULL, sexp_make_integer(newpos*2), SEXP_VOID); + newbuf = sexp_make_string(sexp_stream_ctx(vec), + sexp_make_integer(newpos*2), + SEXP_VOID); memcpy(sexp_string_data(newbuf), sexp_string_data(sexp_stream_buf(vec)), pos); @@ -580,10 +584,11 @@ sexp sexp_make_input_string_port (sexp ctx, sexp str) { sexp res; sexp_gc_var(ctx, cookie, s_cookie); sexp_gc_preserve(ctx, cookie, s_cookie); - cookie = sexp_vector(ctx, 3, str, sexp_make_integer(sexp_string_length(str)), + cookie = sexp_vector(ctx, 4, ctx, str, + sexp_make_integer(sexp_string_length(str)), sexp_make_integer(0)); in = funopen(cookie, &sstream_read, NULL, &sstream_seek, NULL); - res = sexp_make_input_port(ctx, in, NULL); + res = sexp_make_input_port(ctx, in, SEXP_FALSE); sexp_port_cookie(res) = cookie; sexp_gc_release(ctx, cookie, s_cookie); return res; @@ -595,10 +600,10 @@ sexp sexp_make_output_string_port (sexp ctx) { sexp_gc_var(ctx, cookie, s_cookie); sexp_gc_preserve(ctx, cookie, s_cookie); size = sexp_make_integer(SEXP_INIT_STRING_PORT_SIZE); - cookie = sexp_vector(ctx, 3, sexp_make_string(NULL, size, SEXP_VOID), + cookie = sexp_vector(ctx, 4, ctx, sexp_make_string(ctx, size, SEXP_VOID), size, sexp_make_integer(0)); out = funopen(cookie, NULL, &sstream_write, &sstream_seek, NULL); - res = sexp_make_output_port(ctx, out, NULL); + res = sexp_make_output_port(ctx, out, SEXP_FALSE); sexp_port_cookie(res) = cookie; sexp_gc_release(ctx, cookie, s_cookie); return res; @@ -617,14 +622,14 @@ sexp sexp_get_output_string (sexp ctx, sexp port) { sexp sexp_make_input_string_port (sexp ctx, sexp str) { FILE *in = fmemopen(sexp_string_data(str), sexp_string_length(str), "r"); - return sexp_make_input_port(in, NULL); + return sexp_make_input_port(ctx, in, SEXP_FALSE); } sexp sexp_make_output_string_port (sexp ctx) { FILE *out; sexp buf = sexp_alloc_type(ctx, string, SEXP_STRING), res; out = open_memstream(&sexp_string_data(buf), &sexp_string_length(buf)); - res = sexp_make_input_port(out, NULL); + res = sexp_make_input_port(ctx, out, SEXP_FALSE); sexp_port_cookie(res) = buf; return res; } @@ -641,18 +646,18 @@ sexp sexp_get_output_string (sexp ctx, sexp port) { #endif -sexp sexp_make_input_port (sexp ctx, FILE* in, char *path) { +sexp sexp_make_input_port (sexp ctx, FILE* in, sexp name) { sexp p = sexp_alloc_type(ctx, port, SEXP_IPORT); sexp_port_stream(p) = in; - sexp_port_name(p) = path; + sexp_port_name(p) = name; sexp_port_line(p) = 0; return p; } -sexp sexp_make_output_port (sexp ctx, FILE* out, char *path) { +sexp sexp_make_output_port (sexp ctx, FILE* out, sexp name) { sexp p = sexp_alloc_type(ctx, port, SEXP_OPORT); sexp_port_stream(p) = out; - sexp_port_name(p) = path; + sexp_port_name(p) = name; sexp_port_line(p) = 0; return p; } @@ -665,7 +670,7 @@ void sexp_write (sexp obj, sexp out) { char *str=NULL; if (! obj) { - sexp_write_string("#", out); + sexp_write_string("#", out); /* shouldn't happen */ } else if (sexp_pointerp(obj)) { switch (sexp_pointer_tag(obj)) { case SEXP_PAIR: diff --git a/sexp.h b/sexp.h index 4e3dd368..94f6c68b 100644 --- a/sexp.h +++ b/sexp.h @@ -6,7 +6,6 @@ #define SEXP_H #include "config.h" -#include "defaults.h" #include #include @@ -14,7 +13,6 @@ #include #include #include -#include #include #include @@ -123,8 +121,8 @@ struct sexp_struct { } symbol; struct { FILE *stream; - char *name; sexp_uint_t line; + sexp name; sexp cookie; } port; struct { @@ -216,7 +214,7 @@ struct sexp_struct { #define sexp_gc_preserve(ctx, x, y) #define sexp_gc_release(ctx, x, y) -#include "gc/include/gc.h" +#include "gc.h" #define sexp_alloc(ctx, size) GC_malloc(size) #define sexp_alloc_atomic(ctx, size) GC_malloc_atomic(size) #define sexp_realloc(ctx, x, size) GC_realloc(x, size) @@ -257,7 +255,6 @@ void *sexp_realloc(sexp ctx, sexp x, size_t size); #endif #define sexp_align(n, bits) (((n)+(1<<(bits))-1)&(((sexp_uint_t)-1)-((1<<(bits))-1))) -#define sexp_heap_align(n) sexp_align(n, 4) #define sexp_sizeof(x) (offsetof(struct sexp_struct, value) \ + sizeof(((sexp)0)->value.x)) @@ -540,8 +537,8 @@ sexp sexp_read_number(sexp ctx, sexp in, int base); sexp sexp_read_raw(sexp ctx, sexp in); sexp sexp_read(sexp ctx, sexp in); sexp sexp_read_from_string(sexp ctx, char *str); -sexp sexp_make_input_port(sexp ctx, FILE* in, char *path); -sexp sexp_make_output_port(sexp ctx, FILE* out, char *path); +sexp sexp_make_input_port(sexp ctx, FILE* in, sexp name); +sexp sexp_make_output_port(sexp ctx, FILE* out, sexp name); sexp sexp_make_input_string_port(sexp ctx, sexp str); sexp sexp_make_output_string_port(sexp ctx); sexp sexp_get_output_string(sexp ctx, sexp port); From 24d9bfc95015c9c11d3aff7b4339edcbf93ade09 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 20 Jun 2009 21:57:28 +0900 Subject: [PATCH 127/154] switching to linking as a library --- Makefile | 62 ++++++++++++++++++----- eval.c | 79 ++++++++++++++++++++---------- gc.c | 2 +- config.h => include/chibi/config.h | 8 +-- eval.h => include/chibi/eval.h | 12 +++-- sexp.h => include/chibi/sexp.h | 78 +++++++++++++++-------------- main.c | 41 +++++----------- sexp.c | 3 +- 8 files changed, 170 insertions(+), 115 deletions(-) rename config.h => include/chibi/config.h (93%) rename eval.h => include/chibi/eval.h (84%) rename sexp.h => include/chibi/sexp.h (89%) diff --git a/Makefile b/Makefile index d5ae1e4f..175688ce 100644 --- a/Makefile +++ b/Makefile @@ -1,29 +1,65 @@ +# -*- makefile-gmake -*- .PHONY: all doc dist clean cleaner test install uninstall all: chibi-scheme -PREFIX=/usr/local +CC ?= cc +PREFIX ?= /usr/local BINDIR=$(PREFIX)/bin LIBDIR=$(PREFIX)/lib -INCDIR=$(PREFIX)/include/chibi-scheme -MODDIR=$(PREFIX)/share/chibi-scheme +INCDIR=$(PREFIX)/include/chibi +MODDIR=$(PREFIX)/share/chibi -LDFLAGS=-lm #-lgc -L/opt/local/lib +ifndef PLATFORM +ifeq ($(shell uname),Darwin) +PLATFORM=macosx +else +PLATFORM=unix +endif +endif -CFLAGS=-Wall -O2 -g #-I/opt/local/include #-save-temps +ifeq ($(PLATFORM),macosx) +SO = .dylib +EXE = +CLIBFLAGS = -dynamiclib +else ifeq ($(PLATFORM),mingw) +SO = .dll +EXE = .exe +CLIBFLAGS = -fPIC shared +else +SO = .so +EXE = +CLIBFLAGS = -fPIC -shared +endif -sexp.o: sexp.c gc.c sexp.h config.h Makefile - gcc -c $(CPPFLAGS) $(CFLAGS) -o $@ $< +ifdef USE_BOEHM +GCLDFLAGS := -lgc +else +GCLDFLAGS := +endif -eval.o: eval.c debug.c opcodes.c eval.h sexp.h config.h Makefile - gcc -c $(CPPFLAGS) $(CFLAGS) -o $@ $< +LDFLAGS := $(LDFLAGS) -lm +CPPFLAGS := $(CPPFLAGS) -Iinclude +CFLAGS := $(CFLAGS) -Wall -O2 -g -main.o: main.c eval.c debug.c opcodes.c eval.h sexp.h config.h Makefile - gcc -c $(CPPFLAGS) $(CFLAGS) -o $@ $< +sexp.o: sexp.c gc.c include/chibi/sexp.h include/chibi/config.h Makefile + $(CC) -c $(CPPFLAGS) $(CFLAGS) -o $@ $< -chibi-scheme: main.o sexp.o - gcc $(CFLAGS) $(LDFLAGS) -o $@ $^ +eval.o: eval.c debug.c opcodes.c include/chibi/eval.h include/chibi/sexp.h include/chibi/config.h Makefile + $(CC) -c $(CPPFLAGS) $(CFLAGS) -o $@ $< + +main.o: main.c eval.c debug.c opcodes.c include/chibi/eval.h include/chibi/sexp.h include/chibi/config.h Makefile + $(CC) -c $(CPPFLAGS) $(CFLAGS) -o $@ $< + +libchibi-scheme$(SO): eval.o sexp.o + $(CC) -dynamiclib -o $@ $^ + +chibi-scheme$(EXE): main.o libchibi-scheme$(SO) + $(CC) $(CPPFLAGS) $(CFLAGS) -o $@ $< $(LDFLAGS) $(GCLDFLAGS) -L. -lchibi-scheme + +chibi-scheme-static$(EXE): main.o eval.o sexp.o + $(CC) $(CFLAGS) -o $@ $^ $(LDFLAGS) $(GCLDFLAGS) clean: rm -f *.o *.i *.s diff --git a/eval.c b/eval.c index e7515c46..50e9efb5 100644 --- a/eval.c +++ b/eval.c @@ -2,7 +2,7 @@ /* Copyright (c) 2009 Alex Shinn. All rights reserved. */ /* BSD-style license: http://synthcode.com/license.txt */ -#include "eval.h" +#include "chibi/eval.h" /************************************************************************/ @@ -248,7 +248,7 @@ static sexp sexp_make_lit(sexp ctx, sexp value) { #define SEXP_STACK_SIZE (sexp_sizeof(stack)+sizeof(sexp)*INIT_STACK_SIZE) -static sexp sexp_make_context(sexp ctx, sexp stack, sexp env) { +sexp sexp_make_context(sexp ctx, sexp stack, sexp env) { sexp_gc_var(ctx, res, save_res); if (ctx) sexp_gc_preserve(ctx, res, save_res); res = sexp_alloc_type(ctx, context, SEXP_CONTEXT); @@ -279,7 +279,7 @@ static sexp sexp_make_context(sexp ctx, sexp stack, sexp env) { return res; } -static sexp sexp_make_child_context(sexp context, sexp lambda) { +sexp sexp_make_child_context(sexp context, sexp lambda) { sexp ctx = sexp_make_context(context, sexp_context_stack(context), sexp_context_env(context)); @@ -582,7 +582,7 @@ static sexp analyze_bind_syntax (sexp ls, sexp eval_ctx, sexp bind_ctx) { && sexp_nullp(sexp_cddar(ls)))) { res = sexp_compile_error(eval_ctx, "bad syntax binding", sexp_car(ls)); } else { - proc = eval_in_context(eval_ctx, sexp_cadar(ls)); + proc = sexp_eval(eval_ctx, sexp_cadar(ls)); if (sexp_exceptionp(proc)) { res = proc; break; @@ -697,9 +697,9 @@ static sexp analyze (sexp ctx, sexp object) { tmp = sexp_cons(ctx, sexp_macro_env(op), SEXP_NULL); tmp = sexp_cons(ctx, sexp_context_env(ctx), tmp); tmp = sexp_cons(ctx, x, tmp); - x = apply(sexp_make_child_context(ctx, sexp_context_lambda(ctx)), - sexp_macro_proc(op), - tmp); + x = sexp_apply(sexp_make_child_context(ctx, sexp_context_lambda(ctx)), + sexp_macro_proc(op), + tmp); /* if (in_repl_p) sexp_debug(" => ", x, ctx); */ goto loop; } else if (sexp_opcodep(op)) { @@ -1216,7 +1216,7 @@ static sexp_uint_t sexp_restore_stack(sexp saved, sexp *current) { goto call_error_handler;} \ while (0) -sexp vm (sexp ctx, sexp proc) { +sexp sexp_vm (sexp ctx, sexp proc) { sexp bc = sexp_procedure_code(proc), cp = sexp_procedure_vars(proc); sexp env = sexp_context_env(ctx), *stack = sexp_stack_data(sexp_context_stack(ctx)); @@ -1414,7 +1414,7 @@ sexp vm (sexp ctx, sexp proc) { break; case OP_EVAL: sexp_context_top(ctx) = top; - _ARG1 = eval_in_context(ctx, _ARG1); + _ARG1 = sexp_eval(ctx, _ARG1); sexp_check_exception(); break; case OP_JUMP_UNLESS: @@ -1830,7 +1830,7 @@ static sexp sexp_close_port (sexp ctx, sexp port) { return SEXP_VOID; } -static void sexp_warn_undefs (sexp from, sexp to, sexp out) { +void sexp_warn_undefs (sexp from, sexp to, sexp out) { sexp x; for (x=from; sexp_pairp(x) && x!=to; x=sexp_cdr(x)) if (sexp_cdar(x) == SEXP_UNDEF) { @@ -1862,7 +1862,7 @@ sexp sexp_load (sexp ctx, sexp source, sexp env) { res = in; } else { while ((x=sexp_read(ctx, in)) != (sexp) SEXP_EOF) { - res = eval_in_context(ctx2, x); + res = sexp_eval(ctx2, x); if (sexp_exceptionp(res)) break; } @@ -2013,23 +2013,26 @@ static sexp sexp_make_null_env (sexp ctx, sexp version) { static sexp sexp_make_standard_env (sexp ctx, sexp version) { sexp_uint_t i; - sexp cell, sym; + sexp ctx2, cell, sym, perr_cell, err_cell; sexp_gc_var(ctx, e, s_e); sexp_gc_var(ctx, op, s_op); + sexp_gc_var(ctx, tmp, s_tmp); + sexp_gc_var(ctx, err_handler, s_err); sexp_gc_preserve(ctx, e, s_e); sexp_gc_preserve(ctx, op, s_op); + sexp_gc_preserve(ctx, tmp, s_tmp); + sexp_gc_preserve(ctx, err_handler, s_err); e = sexp_make_null_env(ctx, version); for (i=0; i<(sizeof(opcodes)/sizeof(opcodes[0])); i++) { - /* op = &opcodes[i]; */ op = sexp_copy_opcode(ctx, &opcodes[i]); if (sexp_opcode_opt_param_p(op) && sexp_opcode_default(op)) { - /* op = sexp_copy_opcode(ctx, op); */ sym = sexp_intern(ctx, (char*)sexp_opcode_default(op)); cell = env_cell_create(ctx, e, sym, SEXP_VOID); sexp_opcode_default(op) = cell; } env_define(ctx, e, sexp_intern(ctx, sexp_opcode_name(op)), op); } + /* add io port and interaction env parameters */ env_define(ctx, e, the_cur_in_symbol, sexp_make_input_port(ctx, stdin, SEXP_FALSE)); env_define(ctx, e, the_cur_out_symbol, @@ -2037,13 +2040,35 @@ static sexp sexp_make_standard_env (sexp ctx, sexp version) { env_define(ctx, e, the_cur_err_symbol, sexp_make_output_port(ctx, stderr, SEXP_FALSE)); env_define(ctx, e, the_interaction_env_symbol, e); + /* add default exception handler */ + err_cell = env_cell(e, the_cur_err_symbol); + perr_cell = env_cell(e, sexp_intern(ctx, "print-exception")); + ctx2 = sexp_make_context(ctx, sexp_context_stack(ctx), e); + sexp_context_tailp(ctx2) = 0; + if (err_cell && perr_cell && sexp_opcodep(sexp_cdr(perr_cell))) { + emit(ctx2, OP_GLOBAL_KNOWN_REF); + emit_word(ctx2, (sexp_uint_t)err_cell); + emit(ctx2, OP_LOCAL_REF); + emit_word(ctx2, 0); + emit(ctx2, OP_FCALL2); + emit_word(ctx2, (sexp_uint_t)sexp_opcode_data(sexp_cdr(perr_cell))); + } + emit_push(ctx2, SEXP_VOID); + emit(ctx2, OP_DONE); + tmp = sexp_make_vector(ctx2, 0, SEXP_VOID); + err_handler = sexp_make_procedure(ctx2, + sexp_make_integer(0), + sexp_make_integer(0), + finalize_bytecode(ctx2), + tmp); + env_define(ctx2, e, the_err_handler_symbol, err_handler); sexp_gc_release(ctx, e, s_e); return e; } /************************** eval interface ****************************/ -sexp apply (sexp ctx, sexp proc, sexp args) { +sexp sexp_apply (sexp ctx, sexp proc, sexp args) { sexp ls, *stack = sexp_stack_data(sexp_context_stack(ctx)); sexp_sint_t top = sexp_context_top(ctx), offset; offset = top + sexp_unbox_integer(sexp_length(ctx, args)); @@ -2055,10 +2080,10 @@ sexp apply (sexp ctx, sexp proc, sexp args) { stack[top++] = sexp_make_integer(sexp_bytecode_data(final_resumer)); stack[top++] = sexp_make_vector(ctx, 0, SEXP_VOID); stack[top++] = sexp_make_integer(0); - return vm(ctx, proc); + return sexp_vm(ctx, proc); } -sexp compile (sexp ctx, sexp x) { +sexp sexp_compile (sexp ctx, sexp x) { sexp_gc_var(ctx, ast, s_ast); sexp_gc_var(ctx, ctx2, s_ctx2); sexp_gc_var(ctx, vec, s_vec); @@ -2084,11 +2109,11 @@ sexp compile (sexp ctx, sexp x) { return res; } -sexp eval_in_context (sexp ctx, sexp obj) { +sexp sexp_eval (sexp ctx, sexp obj) { sexp res; sexp_gc_var(ctx, thunk, s_thunk); sexp_gc_preserve(ctx, thunk, s_thunk); - thunk = compile(ctx, obj); + thunk = sexp_compile(ctx, obj); if (sexp_exceptionp(thunk)) { sexp_print_exception(ctx, thunk, env_global_ref(sexp_context_env(ctx), @@ -2096,19 +2121,23 @@ sexp eval_in_context (sexp ctx, sexp obj) { SEXP_FALSE)); res = thunk; } else { - res = apply(ctx, thunk, SEXP_NULL); + res = sexp_apply(ctx, thunk, SEXP_NULL); } sexp_gc_release(ctx, thunk, s_thunk); return res; } -sexp eval (sexp obj, sexp env) { - sexp ctx = sexp_make_context(NULL, NULL, NULL); - sexp_context_env(ctx) = env; - return eval_in_context(ctx, obj); +sexp sexp_eval_string (sexp ctx, char *str) { + sexp res; + sexp_gc_var(ctx, obj, s_obj); + sexp_gc_preserve(ctx, obj, s_obj); + obj = sexp_read_from_string(ctx, str); + res = sexp_eval(ctx, obj); + sexp_gc_release(ctx, obj, s_obj); + return res; } -void scheme_init () { +void sexp_scheme_init () { sexp ctx; if (! scheme_initialized_p) { scheme_initialized_p = 1; diff --git a/gc.c b/gc.c index f881ecd6..37444e04 100644 --- a/gc.c +++ b/gc.c @@ -2,7 +2,7 @@ /* Copyright (c) 2009 Alex Shinn. All rights reserved. */ /* BSD-style license: http://synthcode.com/license.txt */ -#include "sexp.h" +#include "chibi/sexp.h" #define SEXP_INITIAL_HEAP_SIZE (2*1024*1024) #define SEXP_MAXIMUM_HEAP_SIZE 0 diff --git a/config.h b/include/chibi/config.h similarity index 93% rename from config.h rename to include/chibi/config.h index bb14e68b..07b993eb 100644 --- a/config.h +++ b/include/chibi/config.h @@ -14,7 +14,7 @@ /* uncomment this if you only want fixnum support */ /* #define USE_FLONUMS 0 */ -/* uncomment this if you want immediate flonums (experimental) */ +/* uncomment this if you want immediate flonums */ /* #define USE_IMMEDIATE_FLONUMS 1 */ /* uncomment this if you don't need extended math operations */ @@ -32,8 +32,8 @@ /* uncomment this to disable string ports */ /* #define USE_STRING_STREAMS 0 */ -/* uncomment this to disable stack checks */ -/* #define USE_CHECK_STACK 0 */ +/* uncomment this to enable stack overflow checks */ +/* #define USE_CHECK_STACK 1 */ /* uncomment this to enable debugging utilities */ /* #define USE_DEBUG 1 */ @@ -101,6 +101,6 @@ #endif #ifndef USE_CHECK_STACK -#define USE_CHECK_STACK 1 +#define USE_CHECK_STACK 0 #endif diff --git a/eval.h b/include/chibi/eval.h similarity index 84% rename from eval.h rename to include/chibi/eval.h index ee870110..65fc66a1 100644 --- a/eval.h +++ b/include/chibi/eval.h @@ -14,8 +14,6 @@ #define sexp_init_file "init.scm" -#define sexp_debug(msg, obj, ctx) (sexp_write_string(msg,env_global_ref(sexp_context_env(ctx), the_cur_err_symbol, SEXP_FALSE)), sexp_write(obj, env_global_ref(sexp_context_env(ctx), the_cur_err_symbol, SEXP_FALSE)), sexp_write_char('\n',env_global_ref(sexp_context_env(ctx), the_cur_err_symbol, SEXP_FALSE))) - /* procedure types */ typedef sexp (*sexp_proc0) (); typedef sexp (*sexp_proc1) (sexp); @@ -130,9 +128,13 @@ enum opcode_names { /**************************** prototypes ******************************/ -sexp apply(sexp proc, sexp args, sexp context); -sexp eval_in_context(sexp expr, sexp context); -sexp eval(sexp expr, sexp env); +SEXP_API void sexp_scheme_init(); +SEXP_API sexp sexp_apply(sexp context, sexp proc, sexp args); +SEXP_API sexp sexp_eval(sexp context, sexp obj); +SEXP_API sexp sexp_eval_string(sexp context, char *str); +SEXP_API sexp sexp_load(sexp context, sexp expr, sexp env); +SEXP_API sexp sexp_make_context(sexp context, sexp stack, sexp env); +SEXP_API void sexp_warn_undefs (sexp from, sexp to, sexp out); #endif /* ! SEXP_EVAL_H */ diff --git a/sexp.h b/include/chibi/sexp.h similarity index 89% rename from sexp.h rename to include/chibi/sexp.h index 94f6c68b..c4979f02 100644 --- a/sexp.h +++ b/include/chibi/sexp.h @@ -16,6 +16,10 @@ #include #include +#ifndef SEXP_API +#define SEXP_API extern +#endif + /* tagging system * bits end in 00: pointer * 01: fixnum @@ -511,43 +515,43 @@ sexp sexp_make_flonum(sexp ctx, double f); #define sexp_scanf(p, ...) (fscanf(sexp_port_stream(p), __VA_ARGS__)) #define sexp_flush(p) (fflush(sexp_port_stream(p))) -sexp sexp_alloc_tagged(sexp ctx, size_t size, sexp_uint_t tag); -sexp sexp_cons(sexp ctx, sexp head, sexp tail); -sexp sexp_list2(sexp ctx, sexp a, sexp b); -sexp sexp_equalp (sexp ctx, sexp a, sexp b); -sexp sexp_listp(sexp ctx, sexp obj); -sexp sexp_reverse(sexp ctx, sexp ls); -sexp sexp_nreverse(sexp ctx, sexp ls); -sexp sexp_append2(sexp ctx, sexp a, sexp b); -sexp sexp_memq(sexp ctx, sexp x, sexp ls); -sexp sexp_assq(sexp ctx, sexp x, sexp ls); -sexp sexp_length(sexp ctx, sexp ls); -sexp sexp_c_string(sexp ctx, char *str, sexp_sint_t slen); -sexp sexp_make_string(sexp ctx, sexp len, sexp ch); -sexp sexp_substring (sexp ctx, sexp str, sexp start, sexp end); -sexp sexp_intern(sexp ctx, char *str); -sexp sexp_string_to_symbol(sexp ctx, sexp str); -sexp sexp_make_vector(sexp ctx, sexp len, sexp dflt); -sexp sexp_list_to_vector(sexp ctx, sexp ls); -sexp sexp_vector(sexp ctx, int count, ...); -void sexp_write(sexp obj, sexp out); -sexp sexp_read_string(sexp ctx, sexp in); -sexp sexp_read_symbol(sexp ctx, sexp in, int init, int internp); -sexp sexp_read_number(sexp ctx, sexp in, int base); -sexp sexp_read_raw(sexp ctx, sexp in); -sexp sexp_read(sexp ctx, sexp in); -sexp sexp_read_from_string(sexp ctx, char *str); -sexp sexp_make_input_port(sexp ctx, FILE* in, sexp name); -sexp sexp_make_output_port(sexp ctx, FILE* out, sexp name); -sexp sexp_make_input_string_port(sexp ctx, sexp str); -sexp sexp_make_output_string_port(sexp ctx); -sexp sexp_get_output_string(sexp ctx, sexp port); -sexp sexp_make_exception(sexp ctx, sexp kind, sexp message, sexp irritants, sexp procedure, sexp file, sexp line); -sexp sexp_user_exception (sexp ctx, sexp self, char *message, sexp obj); -sexp sexp_type_exception (sexp ctx, char *message, sexp obj); -sexp sexp_range_exception (sexp ctx, sexp obj, sexp start, sexp end); -sexp sexp_print_exception(sexp ctx, sexp exn, sexp out); -void sexp_init(); +SEXP_API sexp sexp_alloc_tagged(sexp ctx, size_t size, sexp_uint_t tag); +SEXP_API sexp sexp_cons(sexp ctx, sexp head, sexp tail); +SEXP_API sexp sexp_list2(sexp ctx, sexp a, sexp b); +SEXP_API sexp sexp_equalp (sexp ctx, sexp a, sexp b); +SEXP_API sexp sexp_listp(sexp ctx, sexp obj); +SEXP_API sexp sexp_reverse(sexp ctx, sexp ls); +SEXP_API sexp sexp_nreverse(sexp ctx, sexp ls); +SEXP_API sexp sexp_append2(sexp ctx, sexp a, sexp b); +SEXP_API sexp sexp_memq(sexp ctx, sexp x, sexp ls); +SEXP_API sexp sexp_assq(sexp ctx, sexp x, sexp ls); +SEXP_API sexp sexp_length(sexp ctx, sexp ls); +SEXP_API sexp sexp_c_string(sexp ctx, char *str, sexp_sint_t slen); +SEXP_API sexp sexp_make_string(sexp ctx, sexp len, sexp ch); +SEXP_API sexp sexp_substring (sexp ctx, sexp str, sexp start, sexp end); +SEXP_API sexp sexp_intern(sexp ctx, char *str); +SEXP_API sexp sexp_string_to_symbol(sexp ctx, sexp str); +SEXP_API sexp sexp_make_vector(sexp ctx, sexp len, sexp dflt); +SEXP_API sexp sexp_list_to_vector(sexp ctx, sexp ls); +SEXP_API sexp sexp_vector(sexp ctx, int count, ...); +SEXP_API void sexp_write(sexp obj, sexp out); +SEXP_API sexp sexp_read_string(sexp ctx, sexp in); +SEXP_API sexp sexp_read_symbol(sexp ctx, sexp in, int init, int internp); +SEXP_API sexp sexp_read_number(sexp ctx, sexp in, int base); +SEXP_API sexp sexp_read_raw(sexp ctx, sexp in); +SEXP_API sexp sexp_read(sexp ctx, sexp in); +SEXP_API sexp sexp_read_from_string(sexp ctx, char *str); +SEXP_API sexp sexp_make_input_port(sexp ctx, FILE* in, sexp name); +SEXP_API sexp sexp_make_output_port(sexp ctx, FILE* out, sexp name); +SEXP_API sexp sexp_make_input_string_port(sexp ctx, sexp str); +SEXP_API sexp sexp_make_output_string_port(sexp ctx); +SEXP_API sexp sexp_get_output_string(sexp ctx, sexp port); +SEXP_API sexp sexp_make_exception(sexp ctx, sexp kind, sexp message, sexp irritants, sexp procedure, sexp file, sexp line); +SEXP_API sexp sexp_user_exception (sexp ctx, sexp self, char *message, sexp obj); +SEXP_API sexp sexp_type_exception (sexp ctx, char *message, sexp obj); +SEXP_API sexp sexp_range_exception (sexp ctx, sexp obj, sexp start, sexp end); +SEXP_API sexp sexp_print_exception(sexp ctx, sexp exn, sexp out); +SEXP_API void sexp_init(); #endif /* ! SEXP_H */ diff --git a/main.c b/main.c index 66a6b85b..1beb9889 100644 --- a/main.c +++ b/main.c @@ -1,5 +1,8 @@ +/* main.c -- chibi-scheme command-line app using */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ -#include "eval.c" +#include "chibi/eval.h" void repl (sexp ctx) { sexp tmp, res, env, in, out, err; @@ -7,9 +10,9 @@ void repl (sexp ctx) { sexp_gc_preserve(ctx, obj, s_obj); env = sexp_context_env(ctx); sexp_context_tracep(ctx) = 1; - in = env_global_ref(env, the_cur_in_symbol, SEXP_FALSE); - out = env_global_ref(env, the_cur_out_symbol, SEXP_FALSE); - err = env_global_ref(env, the_cur_err_symbol, SEXP_FALSE); + in = sexp_eval_string(ctx, "(current-input-port)"); + out = sexp_eval_string(ctx, "(current-output-port)"); + err = sexp_eval_string(ctx, "(current-error-port)"); while (1) { sexp_write_string("> ", out); sexp_flush(out); @@ -21,7 +24,7 @@ void repl (sexp ctx) { } else { tmp = sexp_env_bindings(env); sexp_context_top(ctx) = 0; - res = eval_in_context(ctx, obj); + res = sexp_eval(ctx, obj); #if USE_WARN_UNDEFS sexp_warn_undefs(sexp_env_bindings(env), tmp, err); #endif @@ -35,34 +38,14 @@ void repl (sexp ctx) { } void run_main (int argc, char **argv) { - sexp env, out=NULL, res, ctx, perr_cell, err_cell, err_handler; + sexp env, out=NULL, res, ctx; sexp_uint_t i, quit=0, init_loaded=0; sexp_gc_var(ctx, str, s_str); ctx = sexp_make_context(NULL, NULL, NULL); sexp_gc_preserve(ctx, str, s_str); env = sexp_context_env(ctx); - env_define(ctx, env, the_interaction_env_symbol, env); - out = env_global_ref(env, the_cur_out_symbol, SEXP_FALSE); - err_cell = env_cell(env, the_cur_err_symbol); - perr_cell = env_cell(env, sexp_intern(ctx, "print-exception")); - sexp_context_tailp(ctx) = 0; - if (err_cell && perr_cell && sexp_opcodep(sexp_cdr(perr_cell))) { - emit(ctx, OP_GLOBAL_KNOWN_REF); - emit_word(ctx, (sexp_uint_t)err_cell); - emit(ctx, OP_LOCAL_REF); - emit_word(ctx, 0); - emit(ctx, OP_FCALL2); - emit_word(ctx, (sexp_uint_t)sexp_opcode_data(sexp_cdr(perr_cell))); - } - emit_push(ctx, SEXP_VOID); - emit(ctx, OP_DONE); - err_handler = sexp_make_procedure(ctx, - sexp_make_integer(0), - sexp_make_integer(0), - finalize_bytecode(ctx), - sexp_make_vector(ctx, 0, SEXP_VOID)); - env_define(ctx, env, the_err_handler_symbol, err_handler); + out = sexp_eval_string(ctx, "(current-output-port)"); /* parse options */ for (i=1; i < argc && argv[i][0] == '-'; i++) { @@ -74,7 +57,7 @@ void run_main (int argc, char **argv) { sexp_load(ctx, str=sexp_c_string(ctx, sexp_init_file, -1), env); res = sexp_read_from_string(ctx, argv[i+1]); if (! sexp_exceptionp(res)) - res = eval_in_context(ctx, res); + res = sexp_eval(ctx, res); if (sexp_exceptionp(res)) { sexp_print_exception(ctx, res, out); } else if (argv[i][1] == 'p') { @@ -112,7 +95,7 @@ void run_main (int argc, char **argv) { } int main (int argc, char **argv) { - scheme_init(); + sexp_scheme_init(); run_main(argc, argv); return 0; } diff --git a/sexp.c b/sexp.c index ed8071ae..775f64c8 100644 --- a/sexp.c +++ b/sexp.c @@ -2,7 +2,8 @@ /* Copyright (c) 2009 Alex Shinn. All rights reserved. */ /* BSD-style license: http://synthcode.com/license.txt */ -#include "sexp.h" +#define SEXP_API +#include "chibi/sexp.h" /* optional huffman-compressed immediate symbols */ #if USE_HUFF_SYMS From 6f9e9c13215b6589c022686e79fc9dd858832c5c Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 21 Jun 2009 11:58:55 +0900 Subject: [PATCH 128/154] cleaning up build --- Makefile | 51 ++++++++++++++++------------ include/chibi/eval.h | 14 ++++---- include/chibi/sexp.h | 79 +++++++++++++++++++++----------------------- main.c | 42 ++++++++++++++++++++--- 4 files changed, 112 insertions(+), 74 deletions(-) diff --git a/Makefile b/Makefile index 175688ce..4214d381 100644 --- a/Makefile +++ b/Makefile @@ -6,10 +6,10 @@ all: chibi-scheme CC ?= cc PREFIX ?= /usr/local -BINDIR=$(PREFIX)/bin -LIBDIR=$(PREFIX)/lib -INCDIR=$(PREFIX)/include/chibi -MODDIR=$(PREFIX)/share/chibi +BINDIR ?= $(PREFIX)/bin +LIBDIR ?= $(PREFIX)/lib +INCDIR ?= $(PREFIX)/include/chibi +MODDIR ?= $(PREFIX)/share/chibi ifndef PLATFORM ifeq ($(shell uname),Darwin) @@ -23,6 +23,7 @@ ifeq ($(PLATFORM),macosx) SO = .dylib EXE = CLIBFLAGS = -dynamiclib +STATICFLAGS = -static-libgcc else ifeq ($(PLATFORM),mingw) SO = .dll EXE = .exe @@ -31,6 +32,7 @@ else SO = .so EXE = CLIBFLAGS = -fPIC -shared +STATICFLAGS = -static endif ifdef USE_BOEHM @@ -43,13 +45,18 @@ LDFLAGS := $(LDFLAGS) -lm CPPFLAGS := $(CPPFLAGS) -Iinclude CFLAGS := $(CFLAGS) -Wall -O2 -g -sexp.o: sexp.c gc.c include/chibi/sexp.h include/chibi/config.h Makefile +INCLUDES = include/chibi/sexp.h include/chibi/config.h include/chibi/install.h + +include/chibi/install.h: Makefile + echo '#define sexp_module_dir "'$(MODDIR)'"' > $@ + +sexp.o: sexp.c gc.c $(INCLUDES) Makefile $(CC) -c $(CPPFLAGS) $(CFLAGS) -o $@ $< -eval.o: eval.c debug.c opcodes.c include/chibi/eval.h include/chibi/sexp.h include/chibi/config.h Makefile +eval.o: eval.c debug.c opcodes.c include/chibi/eval.h $(INCLUDES) Makefile $(CC) -c $(CPPFLAGS) $(CFLAGS) -o $@ $< -main.o: main.c eval.c debug.c opcodes.c include/chibi/eval.h include/chibi/sexp.h include/chibi/config.h Makefile +main.o: main.c $(INCLUDES) Makefile $(CC) -c $(CPPFLAGS) $(CFLAGS) -o $@ $< libchibi-scheme$(SO): eval.o sexp.o @@ -59,13 +66,13 @@ chibi-scheme$(EXE): main.o libchibi-scheme$(SO) $(CC) $(CPPFLAGS) $(CFLAGS) -o $@ $< $(LDFLAGS) $(GCLDFLAGS) -L. -lchibi-scheme chibi-scheme-static$(EXE): main.o eval.o sexp.o - $(CC) $(CFLAGS) -o $@ $^ $(LDFLAGS) $(GCLDFLAGS) + $(CC) $(CFLAGS) $(STATICFLAGS) -o $@ $^ $(LDFLAGS) $(GCLDFLAGS) clean: rm -f *.o *.i *.s cleaner: clean - rm -f chibi-scheme + rm -f chibi-scheme chibi-scheme-static *$(SO) rm -rf *.dSYM test-basic: chibi-scheme @@ -81,20 +88,20 @@ test-basic: chibi-scheme test: chibi-scheme ./chibi-scheme -l syntax-rules.scm tests/r5rs-tests.scm -# install: chibi-scheme -# cp chibi-scheme $(BINDIR)/ -# mkdir -p $(MODDIR) -# cp init.scm $(MODDIR)/ -# mkdir -p $(INCDIR) -# cp *.h $(INCDIR)/ -# cp *.$(SO) $(LIBDIR)/ +install: chibi-scheme + cp chibi-scheme $(BINDIR)/ + mkdir -p $(MODDIR) + cp init.scm syntax-rules.scm $(MODDIR)/ + mkdir -p $(INCDIR) + cp $(INCLUDES) include/chibi/eval.h $(INCDIR)/ + mkdir -p $(LIBDIR) + cp libchibi-scheme$(SO) $(LIBDIR)/ -# uninstall: -# rm -f $(BINDIR)/chibi-scheme -# rm -f $(LIBDIR)/libchibischeme.$(SO) -# rm -f $(LIBDIR)/libchibisexp.$(SO) -# rm -f $(INCDIR)/*.h -# rm -f $(MODDIR)/*.scm +uninstall: + rm -f $(BINDIR)/chibi-scheme* + rm -f $(LIBDIR)/libchibischeme$(SO) + cd $(INCDIR) && rm -f $(INCLUDES) include/chibi/eval.h + rm -f $(MODDIR)/*.scm dist: cleaner rm -f chibi-scheme-`cat VERSION`.tgz diff --git a/include/chibi/eval.h b/include/chibi/eval.h index 65fc66a1..dcee8420 100644 --- a/include/chibi/eval.h +++ b/include/chibi/eval.h @@ -128,13 +128,13 @@ enum opcode_names { /**************************** prototypes ******************************/ -SEXP_API void sexp_scheme_init(); -SEXP_API sexp sexp_apply(sexp context, sexp proc, sexp args); -SEXP_API sexp sexp_eval(sexp context, sexp obj); -SEXP_API sexp sexp_eval_string(sexp context, char *str); -SEXP_API sexp sexp_load(sexp context, sexp expr, sexp env); -SEXP_API sexp sexp_make_context(sexp context, sexp stack, sexp env); -SEXP_API void sexp_warn_undefs (sexp from, sexp to, sexp out); +void sexp_scheme_init(); +sexp sexp_apply(sexp context, sexp proc, sexp args); +sexp sexp_eval(sexp context, sexp obj); +sexp sexp_eval_string(sexp context, char *str); +sexp sexp_load(sexp context, sexp expr, sexp env); +sexp sexp_make_context(sexp context, sexp stack, sexp env); +void sexp_warn_undefs (sexp from, sexp to, sexp out); #endif /* ! SEXP_EVAL_H */ diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index c4979f02..348052d4 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -6,6 +6,7 @@ #define SEXP_H #include "config.h" +#include "install.h" #include #include @@ -16,10 +17,6 @@ #include #include -#ifndef SEXP_API -#define SEXP_API extern -#endif - /* tagging system * bits end in 00: pointer * 01: fixnum @@ -515,43 +512,43 @@ sexp sexp_make_flonum(sexp ctx, double f); #define sexp_scanf(p, ...) (fscanf(sexp_port_stream(p), __VA_ARGS__)) #define sexp_flush(p) (fflush(sexp_port_stream(p))) -SEXP_API sexp sexp_alloc_tagged(sexp ctx, size_t size, sexp_uint_t tag); -SEXP_API sexp sexp_cons(sexp ctx, sexp head, sexp tail); -SEXP_API sexp sexp_list2(sexp ctx, sexp a, sexp b); -SEXP_API sexp sexp_equalp (sexp ctx, sexp a, sexp b); -SEXP_API sexp sexp_listp(sexp ctx, sexp obj); -SEXP_API sexp sexp_reverse(sexp ctx, sexp ls); -SEXP_API sexp sexp_nreverse(sexp ctx, sexp ls); -SEXP_API sexp sexp_append2(sexp ctx, sexp a, sexp b); -SEXP_API sexp sexp_memq(sexp ctx, sexp x, sexp ls); -SEXP_API sexp sexp_assq(sexp ctx, sexp x, sexp ls); -SEXP_API sexp sexp_length(sexp ctx, sexp ls); -SEXP_API sexp sexp_c_string(sexp ctx, char *str, sexp_sint_t slen); -SEXP_API sexp sexp_make_string(sexp ctx, sexp len, sexp ch); -SEXP_API sexp sexp_substring (sexp ctx, sexp str, sexp start, sexp end); -SEXP_API sexp sexp_intern(sexp ctx, char *str); -SEXP_API sexp sexp_string_to_symbol(sexp ctx, sexp str); -SEXP_API sexp sexp_make_vector(sexp ctx, sexp len, sexp dflt); -SEXP_API sexp sexp_list_to_vector(sexp ctx, sexp ls); -SEXP_API sexp sexp_vector(sexp ctx, int count, ...); -SEXP_API void sexp_write(sexp obj, sexp out); -SEXP_API sexp sexp_read_string(sexp ctx, sexp in); -SEXP_API sexp sexp_read_symbol(sexp ctx, sexp in, int init, int internp); -SEXP_API sexp sexp_read_number(sexp ctx, sexp in, int base); -SEXP_API sexp sexp_read_raw(sexp ctx, sexp in); -SEXP_API sexp sexp_read(sexp ctx, sexp in); -SEXP_API sexp sexp_read_from_string(sexp ctx, char *str); -SEXP_API sexp sexp_make_input_port(sexp ctx, FILE* in, sexp name); -SEXP_API sexp sexp_make_output_port(sexp ctx, FILE* out, sexp name); -SEXP_API sexp sexp_make_input_string_port(sexp ctx, sexp str); -SEXP_API sexp sexp_make_output_string_port(sexp ctx); -SEXP_API sexp sexp_get_output_string(sexp ctx, sexp port); -SEXP_API sexp sexp_make_exception(sexp ctx, sexp kind, sexp message, sexp irritants, sexp procedure, sexp file, sexp line); -SEXP_API sexp sexp_user_exception (sexp ctx, sexp self, char *message, sexp obj); -SEXP_API sexp sexp_type_exception (sexp ctx, char *message, sexp obj); -SEXP_API sexp sexp_range_exception (sexp ctx, sexp obj, sexp start, sexp end); -SEXP_API sexp sexp_print_exception(sexp ctx, sexp exn, sexp out); -SEXP_API void sexp_init(); +sexp sexp_alloc_tagged(sexp ctx, size_t size, sexp_uint_t tag); +sexp sexp_cons(sexp ctx, sexp head, sexp tail); +sexp sexp_list2(sexp ctx, sexp a, sexp b); +sexp sexp_equalp (sexp ctx, sexp a, sexp b); +sexp sexp_listp(sexp ctx, sexp obj); +sexp sexp_reverse(sexp ctx, sexp ls); +sexp sexp_nreverse(sexp ctx, sexp ls); +sexp sexp_append2(sexp ctx, sexp a, sexp b); +sexp sexp_memq(sexp ctx, sexp x, sexp ls); +sexp sexp_assq(sexp ctx, sexp x, sexp ls); +sexp sexp_length(sexp ctx, sexp ls); +sexp sexp_c_string(sexp ctx, char *str, sexp_sint_t slen); +sexp sexp_make_string(sexp ctx, sexp len, sexp ch); +sexp sexp_substring (sexp ctx, sexp str, sexp start, sexp end); +sexp sexp_intern(sexp ctx, char *str); +sexp sexp_string_to_symbol(sexp ctx, sexp str); +sexp sexp_make_vector(sexp ctx, sexp len, sexp dflt); +sexp sexp_list_to_vector(sexp ctx, sexp ls); +sexp sexp_vector(sexp ctx, int count, ...); +void sexp_write(sexp obj, sexp out); +sexp sexp_read_string(sexp ctx, sexp in); +sexp sexp_read_symbol(sexp ctx, sexp in, int init, int internp); +sexp sexp_read_number(sexp ctx, sexp in, int base); +sexp sexp_read_raw(sexp ctx, sexp in); +sexp sexp_read(sexp ctx, sexp in); +sexp sexp_read_from_string(sexp ctx, char *str); +sexp sexp_make_input_port(sexp ctx, FILE* in, sexp name); +sexp sexp_make_output_port(sexp ctx, FILE* out, sexp name); +sexp sexp_make_input_string_port(sexp ctx, sexp str); +sexp sexp_make_output_string_port(sexp ctx); +sexp sexp_get_output_string(sexp ctx, sexp port); +sexp sexp_make_exception(sexp ctx, sexp kind, sexp message, sexp irritants, sexp procedure, sexp file, sexp line); +sexp sexp_user_exception (sexp ctx, sexp self, char *message, sexp obj); +sexp sexp_type_exception (sexp ctx, char *message, sexp obj); +sexp sexp_range_exception (sexp ctx, sexp obj, sexp start, sexp end); +sexp sexp_print_exception(sexp ctx, sexp exn, sexp out); +void sexp_init(); #endif /* ! SEXP_H */ diff --git a/main.c b/main.c index 1beb9889..b09a2f87 100644 --- a/main.c +++ b/main.c @@ -2,8 +2,39 @@ /* Copyright (c) 2009 Alex Shinn. All rights reserved. */ /* BSD-style license: http://synthcode.com/license.txt */ +#include #include "chibi/eval.h" +char *chibi_module_dir = NULL; + +sexp find_module_file (sexp ctx, char *file) { + sexp res; + int mlen, flen; + char *path; + struct stat buf; + + if (! stat(file, &buf)) + return sexp_c_string(ctx, file, -1); + if (! chibi_module_dir) { + chibi_module_dir = getenv("CHIBI_MODULE_DIR"); + if (! chibi_module_dir) + chibi_module_dir = sexp_module_dir; + } + mlen = strlen(chibi_module_dir); + flen = strlen(file); + path = (char*) malloc(mlen+flen+2); + memcpy(path, chibi_module_dir, mlen); + path[mlen+1] = '/'; + memcpy(path+mlen+1, file, flen); + path[mlen+flen] = '\0'; + if (! stat(path, &buf)) + res = sexp_c_string(ctx, path, mlen+flen+1); + else + res = SEXP_FALSE; + free(path); + return res; +} + void repl (sexp ctx) { sexp tmp, res, env, in, out, err; sexp_gc_var(ctx, obj, s_obj); @@ -54,7 +85,7 @@ void run_main (int argc, char **argv) { case 'e': case 'p': if (! init_loaded++) - sexp_load(ctx, str=sexp_c_string(ctx, sexp_init_file, -1), env); + sexp_load(ctx, str=find_module_file(ctx, sexp_init_file), env); res = sexp_read_from_string(ctx, argv[i+1]); if (! sexp_exceptionp(res)) res = sexp_eval(ctx, res); @@ -70,12 +101,15 @@ void run_main (int argc, char **argv) { #endif case 'l': if (! init_loaded++) - sexp_load(ctx, str=sexp_c_string(ctx, sexp_init_file, -1), env); - sexp_load(ctx, str=sexp_c_string(ctx, argv[++i], -1), env); + sexp_load(ctx, str=find_module_file(ctx, sexp_init_file), env); + sexp_load(ctx, str=find_module_file(ctx, argv[++i]), env); break; case 'q': init_loaded = 1; break; + case 'm': + chibi_module_dir = argv[++i]; + break; default: errx(1, "unknown option: %s", argv[i]); } @@ -83,7 +117,7 @@ void run_main (int argc, char **argv) { if (! quit) { if (! init_loaded) - sexp_load(ctx, str=sexp_c_string(ctx, sexp_init_file, -1), env); + sexp_load(ctx, str=find_module_file(ctx, sexp_init_file), env); if (i < argc) for ( ; i < argc; i++) sexp_load(ctx, str=sexp_c_string(ctx, argv[i], -1), env); From b9f46680274770262205097da89eae32fb8f1999 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 21 Jun 2009 01:12:20 -0400 Subject: [PATCH 129/154] linux portability fixes --- .hgignore | 2 +- Makefile | 7 ++++--- gc.c | 4 ++-- include/chibi/sexp.h | 2 +- sexp.c | 5 +++-- 5 files changed, 11 insertions(+), 9 deletions(-) diff --git a/.hgignore b/.hgignore index 51566e20..05828695 100644 --- a/.hgignore +++ b/.hgignore @@ -16,4 +16,4 @@ junk* gc gc6.8 chibi-scheme - +include/chibi/install.h diff --git a/Makefile b/Makefile index 4214d381..7606ca9f 100644 --- a/Makefile +++ b/Makefile @@ -37,12 +37,13 @@ endif ifdef USE_BOEHM GCLDFLAGS := -lgc +CPPFLAGS := $(CPPFLAGS) -Iinclude -DUSE_BOEHM=1 else GCLDFLAGS := +CPPFLAGS := $(CPPFLAGS) -Iinclude endif LDFLAGS := $(LDFLAGS) -lm -CPPFLAGS := $(CPPFLAGS) -Iinclude CFLAGS := $(CFLAGS) -Wall -O2 -g INCLUDES = include/chibi/sexp.h include/chibi/config.h include/chibi/install.h @@ -60,10 +61,10 @@ main.o: main.c $(INCLUDES) Makefile $(CC) -c $(CPPFLAGS) $(CFLAGS) -o $@ $< libchibi-scheme$(SO): eval.o sexp.o - $(CC) -dynamiclib -o $@ $^ + $(CC) $(CLIBFLAGS) -o $@ $^ $(LDFLAGS) $(GCLDFLAGS) chibi-scheme$(EXE): main.o libchibi-scheme$(SO) - $(CC) $(CPPFLAGS) $(CFLAGS) -o $@ $< $(LDFLAGS) $(GCLDFLAGS) -L. -lchibi-scheme + $(CC) $(CPPFLAGS) $(CFLAGS) -o $@ $< -L. -lchibi-scheme chibi-scheme-static$(EXE): main.o eval.o sexp.o $(CC) $(CFLAGS) $(STATICFLAGS) -o $@ $^ $(LDFLAGS) $(GCLDFLAGS) diff --git a/gc.c b/gc.c index 37444e04..7144cbee 100644 --- a/gc.c +++ b/gc.c @@ -154,7 +154,7 @@ sexp_heap sexp_make_heap (size_t size) { sexp free, next; sexp_heap h = (sexp_heap) malloc(sizeof(struct sexp_heap) + size); if (! h) { - fprintf(stderr, "out of memory allocating %ld byte heap, aborting\n", size); + fprintf(stderr, "out of memory allocating %lu byte heap, aborting\n", size); exit(70); } h->size = size; @@ -222,7 +222,7 @@ void* sexp_alloc (sexp ctx, size_t size) { sexp_grow_heap(ctx, size); res = sexp_try_alloc(ctx, size); if (! res) { - fprintf(stderr, "out of memory allocating %ld bytes, aborting\n", size); + fprintf(stderr, "out of memory allocating %lu bytes, aborting\n", size); exit(70); } } diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 348052d4..2bbc323c 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -215,7 +215,7 @@ struct sexp_struct { #define sexp_gc_preserve(ctx, x, y) #define sexp_gc_release(ctx, x, y) -#include "gc.h" +#include "gc/gc.h" #define sexp_alloc(ctx, size) GC_malloc(size) #define sexp_alloc_atomic(ctx, size) GC_malloc_atomic(size) #define sexp_realloc(ctx, x, size) GC_realloc(x, size) diff --git a/sexp.c b/sexp.c index 775f64c8..bd1a851b 100644 --- a/sexp.c +++ b/sexp.c @@ -629,7 +629,7 @@ sexp sexp_make_input_string_port (sexp ctx, sexp str) { sexp sexp_make_output_string_port (sexp ctx) { FILE *out; sexp buf = sexp_alloc_type(ctx, string, SEXP_STRING), res; - out = open_memstream(&sexp_string_data(buf), &sexp_string_length(buf)); + out = open_memstream((char**)&sexp_string_data(buf), (size_t*)&sexp_string_length(buf)); res = sexp_make_input_port(ctx, out, SEXP_FALSE); sexp_port_cookie(res) = buf; return res; @@ -638,7 +638,8 @@ sexp sexp_make_output_string_port (sexp ctx) { sexp sexp_get_output_string (sexp ctx, sexp port) { sexp cookie = sexp_port_cookie(port); fflush(sexp_port_stream(port)); - return sexp_substring(cookie, + return sexp_substring(ctx, + cookie, sexp_make_integer(0), sexp_make_integer(sexp_string_length(cookie))); } From 450548e3e2cfb26842349b3afef58c5b3e34e733 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 21 Jun 2009 16:37:58 +0900 Subject: [PATCH 130/154] store difference between ip and bytecode start instead of the raw ip, which may overflow the integer range. --- .hgignore | 1 + Makefile | 24 +++--- README | 41 ++++++++-- eval.c | 23 +++--- include/chibi/sexp.h | 8 +- init.scm | 177 +++++++++++++++++++++++++++++++++++++++++ sexp.c | 6 +- syntax-rules.scm | 182 ------------------------------------------- 8 files changed, 247 insertions(+), 215 deletions(-) delete mode 100644 syntax-rules.scm diff --git a/.hgignore b/.hgignore index 05828695..9d217d26 100644 --- a/.hgignore +++ b/.hgignore @@ -4,6 +4,7 @@ syntax: glob *.s *.o *.so +*.dylib *.dSYM *.orig .hg diff --git a/Makefile b/Makefile index 7606ca9f..8566af34 100644 --- a/Makefile +++ b/Makefile @@ -37,14 +37,14 @@ endif ifdef USE_BOEHM GCLDFLAGS := -lgc -CPPFLAGS := $(CPPFLAGS) -Iinclude -DUSE_BOEHM=1 +XCPPFLAGS := $(CPPFLAGS) -Iinclude -DUSE_BOEHM=1 else GCLDFLAGS := -CPPFLAGS := $(CPPFLAGS) -Iinclude +XCPPFLAGS := $(CPPFLAGS) -Iinclude endif -LDFLAGS := $(LDFLAGS) -lm -CFLAGS := $(CFLAGS) -Wall -O2 -g +XLDFLAGS := $(LDFLAGS) $(GCLDFLAGS) -lm +XCFLAGS := $(CFLAGS) -Wall -O2 -g INCLUDES = include/chibi/sexp.h include/chibi/config.h include/chibi/install.h @@ -52,22 +52,22 @@ include/chibi/install.h: Makefile echo '#define sexp_module_dir "'$(MODDIR)'"' > $@ sexp.o: sexp.c gc.c $(INCLUDES) Makefile - $(CC) -c $(CPPFLAGS) $(CFLAGS) -o $@ $< + $(CC) -c $(XCPPFLAGS) $(XCFLAGS) -o $@ $< eval.o: eval.c debug.c opcodes.c include/chibi/eval.h $(INCLUDES) Makefile - $(CC) -c $(CPPFLAGS) $(CFLAGS) -o $@ $< + $(CC) -c $(XCPPFLAGS) $(XCFLAGS) -o $@ $< main.o: main.c $(INCLUDES) Makefile - $(CC) -c $(CPPFLAGS) $(CFLAGS) -o $@ $< + $(CC) -c $(XCPPFLAGS) $(XCFLAGS) -o $@ $< libchibi-scheme$(SO): eval.o sexp.o - $(CC) $(CLIBFLAGS) -o $@ $^ $(LDFLAGS) $(GCLDFLAGS) + $(CC) $(CLIBFLAGS) -o $@ $^ $(XLDFLAGS) chibi-scheme$(EXE): main.o libchibi-scheme$(SO) - $(CC) $(CPPFLAGS) $(CFLAGS) -o $@ $< -L. -lchibi-scheme + $(CC) $(XCPPFLAGS) $(XCFLAGS) -o $@ $< -L. -lchibi-scheme chibi-scheme-static$(EXE): main.o eval.o sexp.o - $(CC) $(CFLAGS) $(STATICFLAGS) -o $@ $^ $(LDFLAGS) $(GCLDFLAGS) + $(CC) $(XCFLAGS) $(STATICFLAGS) -o $@ $^ $(XLDFLAGS) clean: rm -f *.o *.i *.s @@ -87,12 +87,12 @@ test-basic: chibi-scheme done test: chibi-scheme - ./chibi-scheme -l syntax-rules.scm tests/r5rs-tests.scm + ./chibi-scheme tests/r5rs-tests.scm install: chibi-scheme cp chibi-scheme $(BINDIR)/ mkdir -p $(MODDIR) - cp init.scm syntax-rules.scm $(MODDIR)/ + cp init.scm $(MODDIR)/ mkdir -p $(INCDIR) cp $(INCLUDES) include/chibi/eval.h $(INCDIR)/ mkdir -p $(LIBDIR) diff --git a/README b/README index d5f2b369..bfd07571 100644 --- a/README +++ b/README @@ -2,7 +2,7 @@ Chibi-Scheme -------------- - Simple and Minimal Scheme Implementation + Minimal Scheme Implementation for use as an Extension Language http://synthcode.com/wiki/chibi-scheme/ @@ -15,9 +15,38 @@ macros based on syntactic-closures, string ports and exceptions. Chibi-Scheme is written in highly portable C and supports multiple simultaneous VM instances to run. -To build, just run "make". You can edit the file config.h for a -number of settings, mostly disabling features to make the executable -smaller. Documents and examples for using Chibi-Scheme as a library -for extension scripting will be provided in an upcoming release. +To build, just run "make". This will provide a shared library +"libchibi-scheme", as well as a sample "chibi-scheme" command-line +repl. The "chibi-scheme-static" make target builds an equivalent +static executable. + +You can edit the file config.h for a number of settings, mostly +disabling features to make the executable smaller. You can specify +standard options directly as arguments to make, for example + + make CFLAGS=-Os + +to optimize for size, or + + make LDFLAGS=-L/usr/local/lib CPPFLAGS=-I/usr/local/include + +to compile against a library installed in /usr/local. + +By default Chibi uses a custom, precise, non-moving GC. You can link +against the Boehm conservative GC by editing the config file, or +directly from make with: + + make USE_BOEHM=1 + +See the file main.c for an example of using chibi-scheme as a library. +The essential functions to remember are: + + sexp_make_context(NULL, NULL, NULL) + returns a new context + + sexp_eval(context, expr) + evaluates an s-expression + + sexp_eval_string(context, str) + reads an s-expression from str and evaluates it -syntax-rules must be loaded manually from the file syntax-rules.scm. diff --git a/eval.c b/eval.c index 50e9efb5..f920fae6 100644 --- a/eval.c +++ b/eval.c @@ -1245,7 +1245,7 @@ sexp sexp_vm (sexp ctx, sexp proc) { case OP_RAISE: call_error_handler: stack[top] = (sexp) 1; - stack[top+1] = sexp_make_integer(ip); + stack[top+1] = sexp_make_integer(ip-sexp_bytecode_data(bc)); stack[top+2] = self; stack[top+3] = sexp_make_integer(fp); top += 4; @@ -1269,7 +1269,7 @@ sexp sexp_vm (sexp ctx, sexp proc) { break; case OP_CALLCC: stack[top] = sexp_make_integer(1); - stack[top+1] = sexp_make_integer(ip); + stack[top+1] = sexp_make_integer(ip-sexp_bytecode_data(bc)); stack[top+2] = self; stack[top+3] = sexp_make_integer(fp); tmp1 = _ARG1; @@ -1298,10 +1298,11 @@ sexp sexp_vm (sexp ctx, sexp proc) { /* save frame info */ tmp2 = stack[fp+3]; j = sexp_unbox_integer(stack[fp]); - ip = ((unsigned char*) sexp_unbox_integer(stack[fp+1])) - sizeof(sexp); self = stack[fp+2]; - cp = sexp_procedure_vars(self); bc = sexp_procedure_vars(self); + cp = sexp_procedure_vars(self); + ip = (sexp_bytecode_data(bc) + + sexp_unbox_integer(stack[fp+1])) - sizeof(sexp); /* copy new args into place */ for (k=0; k>SEXP_FIXNUM_BITS) +#define sexp_make_integer(n) ((sexp) ((((sexp_sint_t)(n))<>SEXP_FIXNUM_BITS) -#define sexp_make_character(n) ((sexp) ((((sexp_sint_t)n)<>SEXP_EXTENDED_BITS)) +#define sexp_make_character(n) ((sexp) ((((sexp_sint_t)(n))<>SEXP_EXTENDED_BITS)) #if USE_FLONUMS #define sexp_integer_to_flonum(ctx, x) (sexp_make_flonum(ctx, sexp_unbox_integer(x))) diff --git a/init.scm b/init.scm index f6cf0b94..72ecb2b1 100644 --- a/init.scm +++ b/init.scm @@ -529,3 +529,180 @@ (if (and (pair? res) (eq? *values-tag* (car res))) (apply consumer (cdr res)) (consumer res)))) + +;; syntax-rules + +(define-syntax syntax-rules + (er-macro-transformer + (lambda (expr rename compare) + (let ((lits (cadr expr)) + (forms (cddr expr)) + (count 0) + (_er-macro-transformer (rename 'er-macro-transformer)) + (_lambda (rename 'lambda)) (_let (rename 'let)) + (_begin (rename 'begin)) (_if (rename 'if)) + (_and (rename 'and)) (_or (rename 'or)) + (_eq? (rename 'eq?)) (_equal? (rename 'equal?)) + (_car (rename 'car)) (_cdr (rename 'cdr)) + (_cons (rename 'cons)) (_pair? (rename 'pair?)) + (_null? (rename 'null?)) (_expr (rename 'expr)) + (_rename (rename 'rename)) (_compare (rename 'compare)) + (_quote (rename 'quote)) (_apply (rename 'apply)) + (_append (rename 'append)) (_map (rename 'map)) + (_vector? (rename 'vector?)) (_list? (rename 'list?)) + (_lp (rename 'lp)) (_reverse (rename 'reverse)) + (_vector->list (rename 'vector->list)) + (_list->vector (rename 'list->vector))) + (define (next-v) + (set! count (+ count 1)) + (rename (string->symbol (string-append "v." (number->string count))))) + (define (expand-pattern pat tmpl) + (let lp ((p (cdr pat)) + (x (list _cdr _expr)) + (dim 0) + (vars '()) + (k (lambda (vars) + (or (expand-template tmpl vars) + (list _begin #f))))) + (let ((v (next-v))) + (list + _let (list (list v x)) + (cond + ((identifier? p) + (if (any (lambda (l) (compare p l)) lits) + (list _and (list _compare v (list _quote p)) (k vars)) + (list _let (list (list p v)) (k (cons (cons p dim) vars))))) + ((ellipse? p) + (cond + ((not (null? (cddr p))) + (error "non-trailing ellipse")) + ((identifier? (car p)) + (list _and (list _list? v) + (list _let (list (list (car p) v)) + (k (cons (cons (car p) (+ 1 dim)) vars))))) + (else + (let* ((w (next-v)) + (new-vars (all-vars (car p) (+ dim 1))) + (ls-vars (map (lambda (x) + (rename + (string->symbol + (string-append + (symbol->string + (identifier->symbol (car x))) + "-ls")))) + new-vars)) + (once + (lp (car p) (list _car w) (+ dim 1) '() + (lambda (_) + (cons + _lp + (cons + (list _cdr w) + (map (lambda (x l) + (list _cons (car x) l)) + new-vars + ls-vars))))))) + (list + _let + _lp (cons (list w v) + (map (lambda (x) (list x '())) ls-vars)) + (list _if (list _null? w) + (list _let (map (lambda (x l) + (list (car x) (list _reverse l))) + new-vars + ls-vars) + (k (append new-vars vars))) + (list _and (list _pair? w) once))))))) + ((pair? p) + (list _and (list _pair? v) + (lp (car p) + (list _car v) + dim + vars + (lambda (vars) + (lp (cdr p) (list _cdr v) dim vars k))))) + ((vector? p) + (list _and + (list _vector? v) + (lp (vector->list p) (list _vector->list v) dim vars k))) + ((null? p) (list _and (list _null? v) (k vars))) + (else (list _and (list _equal? v p) (k vars)))))))) + (define (ellipse? x) + (and (pair? x) (pair? (cdr x)) (compare '... (cadr x)))) + (define (ellipse-depth x) + (if (ellipse? x) + (+ 1 (ellipse-depth (cdr x))) + 0)) + (define (ellipse-tail x) + (if (ellipse? x) + (ellipse-tail (cdr x)) + (cdr x))) + (define (all-vars x dim) + (let lp ((x x) (dim dim) (vars '())) + (cond ((identifier? x) (if (memq x (list _quote lits)) + vars + (cons (cons x dim) vars))) + ((ellipse? x) (lp (car x) (+ dim 1) vars)) + ((pair? x) (lp (car x) dim (lp (cdr x) dim vars))) + ((vector? x) (lp (vector->list x) dim vars)) + (else vars)))) + (define (free-vars x vars dim) + (let lp ((x x) (free '())) + (cond + ((identifier? x) + (if (and (not (memq x free)) + (cond ((assq x vars) => (lambda (cell) (>= (cdr cell) dim))) + (else #f))) + (cons x free) + free)) + ((pair? x) (lp (car x) (lp (cdr x) free))) + ((vector? x) (lp (vector->list x) free)) + (else free)))) + (define (expand-template tmpl vars) + (let lp ((t tmpl) (dim 0)) + (cond + ((identifier? t) + (cond + ((assq t vars) + => (lambda (cell) + (if (<= (cdr cell) dim) + t + (error "too few ...'s")))) + (else + (list _rename (list _quote t))))) + ((pair? t) + (if (ellipse? t) + (let* ((depth (ellipse-depth t)) + (ell-dim (+ dim depth)) + (ell-vars (free-vars (car t) vars ell-dim))) + (if (null? ell-vars) + (error "too many ...'s") + (let* ((once (lp (car t) ell-dim)) + (nest (if (and (null? (cdr ell-vars)) + (identifier? once) + (eq? once (car vars))) + once ;; shortcut + (cons _map + (cons (list _lambda ell-vars once) + ell-vars)))) + (many (do ((d depth (- d 1)) + (many nest + (list _apply _append many))) + ((= d 1) many)))) + (if (null? (ellipse-tail t)) + many ;; shortcut + (list _append many (lp (ellipse-tail t) dim)))))) + (list _cons (lp (car t) dim) (lp (cdr t) dim)))) + ((vector? t) (list _list->vector (lp (vector->list t) dim))) + ((null? t) (list _quote '())) + (else t)))) + (list + _er-macro-transformer + (list _lambda (list _expr _rename _compare) + (cons + _or + (append + (map + (lambda (clause) (expand-pattern (car clause) (cadr clause))) + forms) + (list (list 'error "no expansion")))))))))) diff --git a/sexp.c b/sexp.c index bd1a851b..5835c5b6 100644 --- a/sexp.c +++ b/sexp.c @@ -53,6 +53,8 @@ sexp sexp_alloc_tagged(sexp ctx, size_t size, sexp_uint_t tag) { return res; } +#if ! USE_BOEHM + #define _DEF_TYPE(t,fb,flb,flo,fls,sb,so,sc,n) \ {.tag=SEXP_TYPE, .value={.type={t,fb,flb,flo,fls,sb,so,sc,n}}} @@ -90,11 +92,11 @@ static struct sexp_struct sexp_types[] = { #undef _DEF_TYPE -#if ! USE_BOEHM #if ! USE_MALLOC #include "gc.c" #endif -#endif + +#endif /* ! USE_BOEHM */ /***************************** exceptions *****************************/ diff --git a/syntax-rules.scm b/syntax-rules.scm deleted file mode 100644 index 468c4bdf..00000000 --- a/syntax-rules.scm +++ /dev/null @@ -1,182 +0,0 @@ - -(define-syntax syntax-rules - (er-macro-transformer - (lambda (expr rename compare) - (let ((lits (cadr expr)) - (forms (cddr expr)) - (count 0) - (_er-macro-transformer (rename 'er-macro-transformer)) - (_lambda (rename 'lambda)) (_let (rename 'let)) - (_begin (rename 'begin)) (_if (rename 'if)) - (_and (rename 'and)) (_or (rename 'or)) - (_eq? (rename 'eq?)) (_equal? (rename 'equal?)) - (_car (rename 'car)) (_cdr (rename 'cdr)) - (_cons (rename 'cons)) (_pair? (rename 'pair?)) - (_null? (rename 'null?)) (_expr (rename 'expr)) - (_rename (rename 'rename)) (_compare (rename 'compare)) - (_quote (rename 'quote)) (_apply (rename 'apply)) - (_append (rename 'append)) (_map (rename 'map)) - (_vector? (rename 'vector?)) (_list? (rename 'list?)) - (_lp (rename 'lp)) (_reverse (rename 'reverse)) - (_vector->list (rename 'vector->list)) - (_list->vector (rename 'list->vector))) - (define (next-v) - (set! count (+ count 1)) - (rename (string->symbol (string-append "v." (number->string count))))) - (define (expand-pattern pat tmpl) - (let lp ((p (cdr pat)) - (x (list _cdr _expr)) - (dim 0) - (vars '()) - (k (lambda (vars) - (or (expand-template tmpl vars) - (list _begin #f))))) - (let ((v (next-v))) - (list - _let (list (list v x)) - (cond - ((identifier? p) - (if (any (lambda (l) (compare p l)) lits) - (list _and (list _compare v (list _quote p)) (k vars)) - (list _let (list (list p v)) (k (cons (cons p dim) vars))))) - ((ellipse? p) - (cond - ((not (null? (cddr p))) - (error "non-trailing ellipse")) - ((identifier? (car p)) - (list _and (list _list? v) - (list _let (list (list (car p) v)) - (k (cons (cons (car p) (+ 1 dim)) vars))))) - (else - (let* ((w (next-v)) - (new-vars (all-vars (car p) (+ dim 1))) - (ls-vars (map (lambda (x) - (rename - (string->symbol - (string-append - (symbol->string - (identifier->symbol (car x))) - "-ls")))) - new-vars)) - (once - (lp (car p) (list _car w) (+ dim 1) '() - (lambda (_) - (cons - _lp - (cons - (list _cdr w) - (map (lambda (x l) - (list _cons (car x) l)) - new-vars - ls-vars))))))) - (list - _let - _lp (cons (list w v) - (map (lambda (x) (list x '())) ls-vars)) - (list _if (list _null? w) - (list _let (map (lambda (x l) - (list (car x) (list _reverse l))) - new-vars - ls-vars) - (k (append new-vars vars))) - (list _and (list _pair? w) once))))))) - ((pair? p) - (list _and (list _pair? v) - (lp (car p) - (list _car v) - dim - vars - (lambda (vars) - (lp (cdr p) (list _cdr v) dim vars k))))) - ((vector? p) - (list _and - (list _vector? v) - (lp (vector->list p) (list _vector->list v) dim vars k))) - ((null? p) (list _and (list _null? v) (k vars))) - (else (list _and (list _equal? v p) (k vars)))))))) - (define (ellipse? x) - (and (pair? x) (pair? (cdr x)) (compare '... (cadr x)))) - (define (ellipse-depth x) - (if (ellipse? x) - (+ 1 (ellipse-depth (cdr x))) - 0)) - (define (ellipse-tail x) - (if (ellipse? x) - (ellipse-tail (cdr x)) - (cdr x))) - (define (all-vars x dim) - (let lp ((x x) (dim dim) (vars '())) - (cond ((identifier? x) (if (memq x (list _quote lits)) - vars - (cons (cons x dim) vars))) - ((ellipse? x) (lp (car x) (+ dim 1) vars)) - ((pair? x) (lp (car x) dim (lp (cdr x) dim vars))) - ((vector? x) (lp (vector->list x) dim vars)) - (else vars)))) - (define (free-vars x vars dim) - (let lp ((x x) (free '())) - (cond - ((identifier? x) - (if (and (not (memq x free)) - (cond ((assq x vars) => (lambda (cell) (>= (cdr cell) dim))) - (else #f))) - (cons x free) - free)) - ((pair? x) (lp (car x) (lp (cdr x) free))) - ((vector? x) (lp (vector->list x) free)) - (else free)))) - (define (expand-template tmpl vars) - (let lp ((t tmpl) (dim 0)) - (cond - ((identifier? t) - (cond - ((assq t vars) - => (lambda (cell) - (if (<= (cdr cell) dim) - t - (error "too few ...'s")))) - (else - (list _rename (list _quote t))))) - ((pair? t) - (if (ellipse? t) - (let* ((depth (ellipse-depth t)) - (ell-dim (+ dim depth)) - (ell-vars (free-vars (car t) vars ell-dim))) - (if (null? ell-vars) - (error "too many ...'s") - (let* ((once (lp (car t) ell-dim)) - (nest (if (and (null? (cdr ell-vars)) - (identifier? once) - (eq? once (car vars))) - once ;; shortcut - (cons _map - (cons (list _lambda ell-vars once) - ell-vars)))) - (many (do ((d depth (- d 1)) - (many nest - (list _apply _append many))) - ((= d 1) many)))) - (if (null? (ellipse-tail t)) - many ;; shortcut - (list _append many (lp (ellipse-tail t) dim)))))) - (list _cons (lp (car t) dim) (lp (cdr t) dim)))) - ((vector? t) (list _list->vector (lp (vector->list t) dim))) - ((null? t) (list _quote '())) - (else t)))) - (list - _er-macro-transformer - (list _lambda (list _expr _rename _compare) - (cons - _or - (append - (map - (lambda (clause) (expand-pattern (car clause) (cadr clause))) - forms) - (list (list 'error "no expansion")))))))))) - -;; Local Variables: -;; eval: (put '_lambda 'scheme-indent-function 1) -;; eval: (put '_let 'scheme-indent-function 'scheme-let-indent) -;; eval: (put '_if 'scheme-indent-function 3) -;; End: - From cafb39674537e42a5a173d78d833f9488f1f4f08 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 21 Jun 2009 04:14:09 -0400 Subject: [PATCH 131/154] fixing output-string ports on linux --- gc.c | 10 ++++++++-- include/chibi/sexp.h | 4 ++++ sexp.c | 13 +++---------- 3 files changed, 15 insertions(+), 12 deletions(-) diff --git a/gc.c b/gc.c index 7144cbee..2972e49b 100644 --- a/gc.c +++ b/gc.c @@ -21,7 +21,11 @@ struct sexp_heap { }; static sexp_heap heap; + +#if USE_DEBUG_GC static sexp* stack_base; +#endif + extern sexp continuation_resumer, final_resumer; static sexp_heap sexp_heap_last (sexp_heap h) { @@ -154,7 +158,7 @@ sexp_heap sexp_make_heap (size_t size) { sexp free, next; sexp_heap h = (sexp_heap) malloc(sizeof(struct sexp_heap) + size); if (! h) { - fprintf(stderr, "out of memory allocating %lu byte heap, aborting\n", size); + fprintf(stderr, "out of memory allocating %zu byte heap, aborting\n", size); exit(70); } h->size = size; @@ -222,7 +226,7 @@ void* sexp_alloc (sexp ctx, size_t size) { sexp_grow_heap(ctx, size); res = sexp_try_alloc(ctx, size); if (! res) { - fprintf(stderr, "out of memory allocating %lu bytes, aborting\n", size); + fprintf(stderr, "out of memory allocating %zu bytes, aborting\n", size); exit(70); } } @@ -232,7 +236,9 @@ void* sexp_alloc (sexp ctx, size_t size) { void sexp_gc_init () { sexp_uint_t size = sexp_heap_align(SEXP_INITIAL_HEAP_SIZE); heap = sexp_make_heap(size); +#if USE_DEBUG_GC /* the +32 is a hack, but this is just for debugging anyway */ stack_base = ((sexp*)&size) + 32; +#endif } diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 1a77abaa..2fd879d6 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -122,7 +122,9 @@ struct sexp_struct { } symbol; struct { FILE *stream; + char *buf; sexp_uint_t line; + size_t size; sexp name; sexp cookie; } port; @@ -364,6 +366,8 @@ sexp sexp_make_flonum(sexp ctx, double f); #define sexp_port_name(p) ((p)->value.port.name) #define sexp_port_line(p) ((p)->value.port.line) #define sexp_port_cookie(p) ((p)->value.port.cookie) +#define sexp_port_buf(p) ((p)->value.port.buf) +#define sexp_port_size(p) ((p)->value.port.size) #define sexp_exception_kind(p) ((p)->value.exception.kind) #define sexp_exception_message(p) ((p)->value.exception.message) diff --git a/sexp.c b/sexp.c index 5835c5b6..aade93c1 100644 --- a/sexp.c +++ b/sexp.c @@ -629,21 +629,14 @@ sexp sexp_make_input_string_port (sexp ctx, sexp str) { } sexp sexp_make_output_string_port (sexp ctx) { - FILE *out; - sexp buf = sexp_alloc_type(ctx, string, SEXP_STRING), res; - out = open_memstream((char**)&sexp_string_data(buf), (size_t*)&sexp_string_length(buf)); - res = sexp_make_input_port(ctx, out, SEXP_FALSE); - sexp_port_cookie(res) = buf; + sexp res = sexp_make_output_port(ctx, NULL, SEXP_FALSE); + sexp_port_stream(res) = open_memstream(&sexp_port_buf(res), &sexp_port_size(res)); return res; } sexp sexp_get_output_string (sexp ctx, sexp port) { - sexp cookie = sexp_port_cookie(port); fflush(sexp_port_stream(port)); - return sexp_substring(ctx, - cookie, - sexp_make_integer(0), - sexp_make_integer(sexp_string_length(cookie))); + return sexp_c_string(ctx, sexp_port_buf(port), sexp_port_size(port)); } #endif From a60cc1e98c6c6b97bdf7ed20b4b455cf745ea8df Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 21 Jun 2009 17:26:36 +0900 Subject: [PATCH 132/154] fixing bug in loading init.scm file --- Makefile | 4 ++-- eval.c | 2 ++ main.c | 8 ++++---- sexp.c | 8 ++++++-- 4 files changed, 14 insertions(+), 8 deletions(-) diff --git a/Makefile b/Makefile index 8566af34..0875ec19 100644 --- a/Makefile +++ b/Makefile @@ -44,7 +44,7 @@ XCPPFLAGS := $(CPPFLAGS) -Iinclude endif XLDFLAGS := $(LDFLAGS) $(GCLDFLAGS) -lm -XCFLAGS := $(CFLAGS) -Wall -O2 -g +XCFLAGS := $(CFLAGS) -Wall -g INCLUDES = include/chibi/sexp.h include/chibi/config.h include/chibi/install.h @@ -100,7 +100,7 @@ install: chibi-scheme uninstall: rm -f $(BINDIR)/chibi-scheme* - rm -f $(LIBDIR)/libchibischeme$(SO) + rm -f $(LIBDIR)/libchibi-scheme$(SO) cd $(INCDIR) && rm -f $(INCLUDES) include/chibi/eval.h rm -f $(MODDIR)/*.scm diff --git a/eval.c b/eval.c index f920fae6..b5faadd9 100644 --- a/eval.c +++ b/eval.c @@ -1828,6 +1828,8 @@ static sexp sexp_open_output_file (sexp ctx, sexp path) { static sexp sexp_close_port (sexp ctx, sexp port) { fclose(sexp_port_stream(port)); + if (sexp_port_buf(port)) + free(sexp_port_buf(port)); return SEXP_VOID; } diff --git a/main.c b/main.c index b09a2f87..42f2d858 100644 --- a/main.c +++ b/main.c @@ -1,4 +1,4 @@ -/* main.c -- chibi-scheme command-line app using */ +/* main.c -- chibi-scheme command-line app */ /* Copyright (c) 2009 Alex Shinn. All rights reserved. */ /* BSD-style license: http://synthcode.com/license.txt */ @@ -24,11 +24,11 @@ sexp find_module_file (sexp ctx, char *file) { flen = strlen(file); path = (char*) malloc(mlen+flen+2); memcpy(path, chibi_module_dir, mlen); - path[mlen+1] = '/'; + path[mlen] = '/'; memcpy(path+mlen+1, file, flen); - path[mlen+flen] = '\0'; + path[mlen+flen+1] = '\0'; if (! stat(path, &buf)) - res = sexp_c_string(ctx, path, mlen+flen+1); + res = sexp_c_string(ctx, path, mlen+flen+2); else res = SEXP_FALSE; free(path); diff --git a/sexp.c b/sexp.c index aade93c1..82c0b73d 100644 --- a/sexp.c +++ b/sexp.c @@ -625,12 +625,15 @@ sexp sexp_get_output_string (sexp ctx, sexp port) { sexp sexp_make_input_string_port (sexp ctx, sexp str) { FILE *in = fmemopen(sexp_string_data(str), sexp_string_length(str), "r"); - return sexp_make_input_port(ctx, in, SEXP_FALSE); + sexp res = sexp_make_input_port(ctx, in, SEXP_FALSE); + sexp_port_cookie(res) = str; /* for gc preservation */ + return res; } sexp sexp_make_output_string_port (sexp ctx) { sexp res = sexp_make_output_port(ctx, NULL, SEXP_FALSE); - sexp_port_stream(res) = open_memstream(&sexp_port_buf(res), &sexp_port_size(res)); + sexp_port_stream(res) + = open_memstream(&sexp_port_buf(res), &sexp_port_size(res)); return res; } @@ -656,6 +659,7 @@ sexp sexp_make_output_port (sexp ctx, FILE* out, sexp name) { sexp_port_stream(p) = out; sexp_port_name(p) = name; sexp_port_line(p) = 0; + sexp_port_buf(p) = NULL; return p; } From 3d46acee56901ca136ea8db66823d09ff92b459d Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 21 Jun 2009 17:38:26 +0900 Subject: [PATCH 133/154] putting back in -O2 --- Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Makefile b/Makefile index 0875ec19..1f900f0a 100644 --- a/Makefile +++ b/Makefile @@ -44,7 +44,7 @@ XCPPFLAGS := $(CPPFLAGS) -Iinclude endif XLDFLAGS := $(LDFLAGS) $(GCLDFLAGS) -lm -XCFLAGS := $(CFLAGS) -Wall -g +XCFLAGS := $(CFLAGS) -Wall -O2 -g INCLUDES = include/chibi/sexp.h include/chibi/config.h include/chibi/install.h From 097d6705defe3a00769623f569493409dff99594 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Mon, 22 Jun 2009 21:30:14 +0900 Subject: [PATCH 134/154] fixes for alternate compile options --- Makefile | 2 +- include/chibi/config.h | 4 ++-- sexp.c | 7 ++++--- 3 files changed, 7 insertions(+), 6 deletions(-) diff --git a/Makefile b/Makefile index 1f900f0a..bad4dbfd 100644 --- a/Makefile +++ b/Makefile @@ -44,7 +44,7 @@ XCPPFLAGS := $(CPPFLAGS) -Iinclude endif XLDFLAGS := $(LDFLAGS) $(GCLDFLAGS) -lm -XCFLAGS := $(CFLAGS) -Wall -O2 -g +XCFLAGS := -Wall -O2 -g $(CFLAGS) INCLUDES = include/chibi/sexp.h include/chibi/config.h include/chibi/install.h diff --git a/include/chibi/config.h b/include/chibi/config.h index 07b993eb..49661145 100644 --- a/include/chibi/config.h +++ b/include/chibi/config.h @@ -35,8 +35,8 @@ /* uncomment this to enable stack overflow checks */ /* #define USE_CHECK_STACK 1 */ -/* uncomment this to enable debugging utilities */ -/* #define USE_DEBUG 1 */ +/* uncomment this to disable debugging utilities */ +/* #define USE_DEBUG 0 */ /************************************************************************/ /* DEFAULTS - DO NOT MODIFY ANYTHING BELOW THIS LINE */ diff --git a/sexp.c b/sexp.c index 82c0b73d..12ed719f 100644 --- a/sexp.c +++ b/sexp.c @@ -6,11 +6,12 @@ #include "chibi/sexp.h" /* optional huffman-compressed immediate symbols */ -#if USE_HUFF_SYMS struct sexp_huff_entry { unsigned char len; unsigned short bits; }; + +#if USE_HUFF_SYMS #include "opt/sexp-hufftabs.c" static struct sexp_huff_entry huff_table[] = { #include "opt/sexp-huff.c" @@ -433,11 +434,11 @@ sexp sexp_substring (sexp ctx, sexp str, sexp start, sexp end) { return res; } -#if USE_HASH_SYMS - #define FNV_PRIME 16777619 #define FNV_OFFSET_BASIS 2166136261uL +#if USE_HASH_SYMS + static sexp_uint_t sexp_string_hash(char *str, sexp_uint_t acc) { while (*str) {acc *= FNV_PRIME; acc ^= *str++;} return acc; From 956b451cdddc896fdaea596ecdf16bd8e9a82f2b Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 23 Jun 2009 11:46:56 +0900 Subject: [PATCH 136/154] Updating resume/cc needs to jump to the start of the procedure bytecode plus the offset on the stack (not directly to the offset on the stack). Need to add a call/cc test to the r5rs-tests to catch this next time. --- eval.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/eval.c b/eval.c index b5faadd9..d49c8295 100644 --- a/eval.c +++ b/eval.c @@ -1262,7 +1262,7 @@ sexp sexp_vm (sexp ctx, sexp proc) { self = _ARG2; bc = sexp_procedure_code(self); cp = sexp_procedure_vars(self); - ip = (unsigned char*) sexp_unbox_integer(_ARG3); + ip = sexp_bytecode_data(bc) + sexp_unbox_integer(_ARG3); i = sexp_unbox_integer(_ARG4); top -= 4; _ARG1 = tmp1; From 6941ada64fb0e8ccf0365460431acb25b1dc2d13 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 23 Jun 2009 11:49:26 +0900 Subject: [PATCH 137/154] Was unintentionally using the same name 'sexp_types' for the sexp type definitions and for the sexp type enum. They shouldn't conflict, since the enum is in the enum namespace, but apparently they do in mscv. Chaging the defs to sexp_type_specs. --- gc.c | 4 ++-- sexp.c | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/gc.c b/gc.c index 2972e49b..c8a980f3 100644 --- a/gc.c +++ b/gc.c @@ -38,7 +38,7 @@ sexp_uint_t sexp_allocated_bytes (sexp x) { sexp t; if ((! sexp_pointerp(x)) || (sexp_pointer_tag(x) > SEXP_CONTEXT)) return sexp_heap_align(1); - t = &(sexp_types[sexp_pointer_tag(x)]); + t = &(sexp_type_specs[sexp_pointer_tag(x)]); len_ptr = (sexp_uint_t*) (((char*)x) + sexp_type_size_off(t)); res = sexp_type_size_base(t) + len_ptr[0] * sexp_type_size_scale(t); return res; @@ -56,7 +56,7 @@ void sexp_mark (sexp x) { if (sexp_contextp(x)) for (saves=sexp_context_saves(x); saves; saves=saves->next) if (saves->var) sexp_mark(*(saves->var)); - t = &(sexp_types[sexp_pointer_tag(x)]); + t = &(sexp_type_specs[sexp_pointer_tag(x)]); p = (sexp*) (((char*)x) + sexp_type_field_base(t)); len_ptr = (sexp_uint_t*) (((char*)x) + sexp_type_field_len_off(t)); len = sexp_type_field_len_base(t) diff --git a/sexp.c b/sexp.c index 12ed719f..24a4d437 100644 --- a/sexp.c +++ b/sexp.c @@ -59,7 +59,7 @@ sexp sexp_alloc_tagged(sexp ctx, size_t size, sexp_uint_t tag) { #define _DEF_TYPE(t,fb,flb,flo,fls,sb,so,sc,n) \ {.tag=SEXP_TYPE, .value={.type={t,fb,flb,flo,fls,sb,so,sc,n}}} -static struct sexp_struct sexp_types[] = { +static struct sexp_struct sexp_type_specs[] = { _DEF_TYPE(SEXP_OBJECT, 0, 0, 0, 0, 0, 0, 0, "object"), _DEF_TYPE(SEXP_TYPE, 0, 0, 0, 0, sexp_sizeof(type), 0, 0, "type"), _DEF_TYPE(SEXP_FIXNUM, 0, 0, 0, 0, 0, 0, 0, "fixnum"), From ddf866ee279875bdc36db68bc819b8c322531a0c Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 23 Jun 2009 11:53:06 +0900 Subject: [PATCH 138/154] adding basic call/cc tests --- tests/r5rs-tests.scm | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/tests/r5rs-tests.scm b/tests/r5rs-tests.scm index e11ced4c..8fc0606e 100644 --- a/tests/r5rs-tests.scm +++ b/tests/r5rs-tests.scm @@ -368,6 +368,10 @@ (test '(3 3) (let ((p (delay (+ 1 2)))) (list (force p) (force p)))) +(test 7 (call-with-current-continuation (lambda (k) (+ 2 5)))) + +(test 3 (call-with-current-continuation (lambda (k) (+ 2 5 (k 3))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (test-report) From 09114aa45df8888eee429b348d2365e599106da2 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Wed, 24 Jun 2009 00:45:54 +0900 Subject: [PATCH 139/154] using -fPIC on object files, running ldconfig on install if available --- Makefile | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/Makefile b/Makefile index bad4dbfd..05fbbc9c 100644 --- a/Makefile +++ b/Makefile @@ -27,7 +27,7 @@ STATICFLAGS = -static-libgcc else ifeq ($(PLATFORM),mingw) SO = .dll EXE = .exe -CLIBFLAGS = -fPIC shared +CLIBFLAGS = -fPIC -shared else SO = .so EXE = @@ -52,10 +52,10 @@ include/chibi/install.h: Makefile echo '#define sexp_module_dir "'$(MODDIR)'"' > $@ sexp.o: sexp.c gc.c $(INCLUDES) Makefile - $(CC) -c $(XCPPFLAGS) $(XCFLAGS) -o $@ $< + $(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -o $@ $< eval.o: eval.c debug.c opcodes.c include/chibi/eval.h $(INCLUDES) Makefile - $(CC) -c $(XCPPFLAGS) $(XCFLAGS) -o $@ $< + $(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -o $@ $< main.o: main.c $(INCLUDES) Makefile $(CC) -c $(XCPPFLAGS) $(XCFLAGS) -o $@ $< @@ -97,6 +97,7 @@ install: chibi-scheme cp $(INCLUDES) include/chibi/eval.h $(INCDIR)/ mkdir -p $(LIBDIR) cp libchibi-scheme$(SO) $(LIBDIR)/ + if type ldconfig >/dev/null 2>/dev/null; then ldconfig; fi uninstall: rm -f $(BINDIR)/chibi-scheme* From 86ce8fbc15a5bcf9cf2de62f7d83f0099e9edfbb Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Wed, 24 Jun 2009 00:47:49 +0900 Subject: [PATCH 140/154] hygiene fix for nested macros, still need to clean this up --- eval.c | 57 ++++++++++++++++++++++++---------- include/chibi/sexp.h | 1 + sexp.c | 30 +++++++++++++++--- tests/basic/test09-hygiene.res | 2 ++ tests/basic/test09-hygiene.scm | 37 ++++++++++++++++++++++ 5 files changed, 106 insertions(+), 21 deletions(-) diff --git a/eval.c b/eval.c index d49c8295..33a6d84e 100644 --- a/eval.c +++ b/eval.c @@ -13,6 +13,9 @@ static sexp the_interaction_env_symbol; static sexp the_err_handler_symbol, the_compile_error_symbol; static sexp the_cur_in_symbol, the_cur_out_symbol, the_cur_err_symbol; +#define sexp_current_error_port(ctx) env_global_ref(sexp_context_env(ctx),the_cur_out_symbol,SEXP_FALSE) +#define sexp_debug(ctx, msg, obj) (sexp_write_string(msg, sexp_current_error_port(ctx)), sexp_write(obj, sexp_current_error_port(ctx)), sexp_write_char('\n', sexp_current_error_port(ctx))) + #if USE_DEBUG #include "debug.c" #else @@ -67,7 +70,7 @@ static void env_define(sexp ctx, sexp e, sexp key, sexp value) { sexp cell = sexp_assq(ctx, key, sexp_env_bindings(e)); sexp_gc_var(ctx, tmp, s_tmp); sexp_gc_preserve(ctx, tmp, s_tmp); - if (cell != SEXP_FALSE) + if (sexp_truep(cell)) sexp_cdr(cell) = value; else { tmp = sexp_cons(ctx, key, value); @@ -92,6 +95,20 @@ static sexp extend_env (sexp ctx, sexp env, sexp vars, sexp value) { return e; } +static sexp sexp_chain_env (sexp ctx, sexp env1, sexp env2) { + sexp_gc_var(ctx, res, s_res); + sexp_gc_preserve(ctx, res, s_res); + res = env2; + if (env1 && sexp_envp(env1)) { + res = sexp_alloc_type(ctx, env, SEXP_ENV); + sexp_env_parent(res) = sexp_chain_env(ctx, sexp_env_parent(env1), env2); + sexp_env_bindings(res) = sexp_env_bindings(env1); + sexp_env_lambda(res) = sexp_env_lambda(env1); + } + sexp_gc_release(ctx, res, s_res); + return res; +} + static sexp sexp_reverse_flatten_dot (sexp ctx, sexp ls) { sexp_gc_var(ctx, res, s_res); sexp_gc_preserve(ctx, res, s_res); @@ -403,7 +420,7 @@ static sexp analyze_var_ref (sexp ctx, sexp x) { cell = env_cell(env, x); if (! cell) { if (sexp_synclop(x)) { - if (sexp_memq(ctx, x, sexp_context_fv(ctx)) != SEXP_FALSE) + if (sexp_truep(sexp_memq(ctx, x, sexp_context_fv(ctx)))) env = sexp_synclo_env(x); x = sexp_synclo_expr(x); } @@ -464,7 +481,7 @@ static sexp analyze_lambda (sexp ctx, sexp x) { for (ls=sexp_cadr(x); sexp_pairp(ls); ls=sexp_cdr(ls)) if (! sexp_idp(sexp_car(ls))) sexp_return(res, sexp_compile_error(ctx, "non-symbol parameter", x)); - else if (sexp_memq(ctx, sexp_car(ls), sexp_cdr(ls)) != SEXP_FALSE) + else if (sexp_truep(sexp_memq(ctx, sexp_car(ls), sexp_cdr(ls)))) sexp_return(res, sexp_compile_error(ctx, "duplicate parameter", x)); /* build lambda and analyze body */ res = sexp_make_lambda(ctx, sexp_cadr(x)); @@ -583,13 +600,14 @@ static sexp analyze_bind_syntax (sexp ls, sexp eval_ctx, sexp bind_ctx) { res = sexp_compile_error(eval_ctx, "bad syntax binding", sexp_car(ls)); } else { proc = sexp_eval(eval_ctx, sexp_cadar(ls)); - if (sexp_exceptionp(proc)) { - res = proc; - break; - } else if (sexp_procedurep(proc)) { - mac = sexp_make_macro(eval_ctx, proc, sexp_context_env(eval_ctx)); + if (sexp_procedurep(proc)) { + mac = sexp_make_macro(eval_ctx, proc, sexp_context_env(bind_ctx)); tmp = sexp_cons(eval_ctx, sexp_caar(ls), mac); sexp_push(eval_ctx, sexp_env_bindings(sexp_context_env(bind_ctx)), tmp); + } else { + res = (sexp_exceptionp(proc) ? proc + : sexp_compile_error(eval_ctx, "non-procedure macro:", proc)); + break; } } } @@ -619,8 +637,10 @@ static sexp analyze_let_syntax (sexp ctx, sexp x) { res = sexp_compile_error(ctx, "bad let-syntax", x); } else { env = sexp_alloc_type(ctx, env, SEXP_ENV); - sexp_env_parent(env) = sexp_env_parent(sexp_context_env(ctx)); - sexp_env_bindings(env) = sexp_env_bindings(sexp_context_env(ctx)); +/* sexp_env_parent(env) = sexp_env_parent(sexp_context_env(ctx)); */ +/* sexp_env_bindings(env) = sexp_env_bindings(sexp_context_env(ctx)); */ + sexp_env_parent(env) = sexp_context_env(ctx); + sexp_env_bindings(env) = SEXP_NULL; ctx2 = sexp_make_child_context(ctx, sexp_context_lambda(ctx)); sexp_context_env(ctx2) = env; tmp = analyze_bind_syntax(sexp_cadr(x), ctx, ctx2); @@ -657,7 +677,7 @@ static sexp analyze (sexp ctx, sexp object) { x = object; loop: if (sexp_pairp(x)) { - if (sexp_listp(ctx, x) == SEXP_FALSE) { + if (sexp_not(sexp_listp(ctx, x))) { res = sexp_compile_error(ctx, "dotted list in source", x); } else if (sexp_idp(sexp_car(x))) { cell = env_cell(sexp_context_env(ctx), sexp_car(x)); @@ -693,15 +713,18 @@ static sexp analyze (sexp ctx, sexp object) { res = sexp_compile_error(ctx, "unknown core form", op); break; } } else if (sexp_macrop(op)) { - /* if (in_repl_p) sexp_debug("expand: ", x, ctx); */ tmp = sexp_cons(ctx, sexp_macro_env(op), SEXP_NULL); tmp = sexp_cons(ctx, sexp_context_env(ctx), tmp); tmp = sexp_cons(ctx, x, tmp); - x = sexp_apply(sexp_make_child_context(ctx, sexp_context_lambda(ctx)), - sexp_macro_proc(op), - tmp); - /* if (in_repl_p) sexp_debug(" => ", x, ctx); */ - goto loop; + x = sexp_make_child_context(ctx, sexp_context_lambda(ctx)); + sexp_context_env(x) = sexp_macro_env(op); + x = sexp_apply(x, sexp_macro_proc(op), tmp); + /* goto loop; */ + /* XXXX need to handle free vars, simplify */ + tmp = sexp_make_child_context(ctx, sexp_context_lambda(ctx)); + sexp_context_env(tmp) + = sexp_chain_env(ctx, sexp_macro_env(op), sexp_context_env(tmp)); + res = analyze(tmp, x); } else if (sexp_opcodep(op)) { res = sexp_length(ctx, sexp_cdr(x)); if (sexp_unbox_integer(res) < sexp_opcode_num_args(op)) { diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 2fd879d6..788d4a12 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -269,6 +269,7 @@ void *sexp_realloc(sexp ctx, sexp x, size_t size); /***************************** predicates *****************************/ #define sexp_truep(x) ((x) != SEXP_FALSE) +#define sexp_not(x) ((x) == SEXP_FALSE) #define sexp_nullp(x) ((x) == SEXP_NULL) #define sexp_pointerp(x) (((sexp_uint_t)(x) & SEXP_FIXNUM_MASK) == SEXP_POINTER_TAG) diff --git a/sexp.c b/sexp.c index 24a4d437..2b83aa91 100644 --- a/sexp.c +++ b/sexp.c @@ -416,7 +416,7 @@ sexp sexp_substring (sexp ctx, sexp str, sexp start, sexp end) { return sexp_type_exception(ctx, "not a string", str); if (! sexp_integerp(start)) return sexp_type_exception(ctx, "not a number", start); - if (end == SEXP_FALSE) + if (sexp_not(end)) end = sexp_make_integer(sexp_string_length(str)); if (! sexp_integerp(end)) return sexp_type_exception(ctx, "not a number", end); @@ -723,14 +723,36 @@ void sexp_write (sexp obj, sexp out) { case SEXP_BYTECODE: sexp_write_string("#", out); break; case SEXP_ENV: - sexp_printf(out, "#", obj); break; + sexp_printf(out, "# 5) { + sexp_write_char(' ', out); + sexp_write(sexp_caar(x), out); + sexp_write_string(": ", out); + if ((! sexp_cdar(x)) || sexp_pointerp(sexp_cdar(x))) + sexp_printf(out, "%p", sexp_cdar(x)); + else + sexp_write(sexp_cdar(x), out); + sexp_write_string(" ...", out); + } else for ( ; x && sexp_pairp(x); x=sexp_cdr(x)) { + sexp_write_char(' ', out); + sexp_write(sexp_caar(x), out); + sexp_write_string(": ", out); + if ((! sexp_cdar(x)) || sexp_pointerp(sexp_cdar(x))) + sexp_printf(out, "%p", sexp_cdar(x)); + else + sexp_write(sexp_cdar(x), out); + } + sexp_write_char('>', out); + break; case SEXP_EXCEPTION: sexp_write_string("#", out); break; case SEXP_MACRO: sexp_write_string("#", out); break; #if USE_DEBUG case SEXP_LAMBDA: - sexp_write_string("# Date: Sat, 27 Jun 2009 20:28:04 +0900 Subject: [PATCH 141/154] initial plan9 work --- eval.c | 61 +++--- gc.c | 14 +- include/chibi/config.h | 28 ++- include/chibi/eval.h | 2 +- include/chibi/sexp.h | 51 +++-- main.c | 18 +- mkfile | 37 ++++ sexp.c | 461 ++++++++++++++++++++++++++--------------- 8 files changed, 431 insertions(+), 241 deletions(-) create mode 100644 mkfile diff --git a/eval.c b/eval.c index 33a6d84e..9a965345 100644 --- a/eval.c +++ b/eval.c @@ -14,7 +14,7 @@ static sexp the_err_handler_symbol, the_compile_error_symbol; static sexp the_cur_in_symbol, the_cur_out_symbol, the_cur_err_symbol; #define sexp_current_error_port(ctx) env_global_ref(sexp_context_env(ctx),the_cur_out_symbol,SEXP_FALSE) -#define sexp_debug(ctx, msg, obj) (sexp_write_string(msg, sexp_current_error_port(ctx)), sexp_write(obj, sexp_current_error_port(ctx)), sexp_write_char('\n', sexp_current_error_port(ctx))) +#define sexp_debug(ctx, msg, obj) (sexp_write_string(ctx, msg, sexp_current_error_port(ctx)), sexp_write(ctx, obj, sexp_current_error_port(ctx)), sexp_write_char(ctx, '\n', sexp_current_error_port(ctx))) #if USE_DEBUG #include "debug.c" @@ -1298,7 +1298,10 @@ sexp sexp_vm (sexp ctx, sexp proc) { tmp1 = _ARG1; i = 1; sexp_context_top(ctx) = top; - tmp2 = sexp_vector(ctx, 1, sexp_save_stack(ctx, stack, top+4)); + tmp2 = sexp_make_vector(ctx, sexp_make_integer(1), SEXP_UNDEF); + sexp_vector_set(tmp2, + sexp_make_integer(0), + sexp_save_stack(ctx, stack, top+4)); _ARG1 = sexp_make_procedure(ctx, sexp_make_integer(0), sexp_make_integer(1), continuation_resumer, tmp2); @@ -1334,10 +1337,8 @@ sexp sexp_vm (sexp ctx, sexp proc) { goto make_call; case OP_CALL: #if USE_CHECK_STACK - if (top+16 >= INIT_STACK_SIZE) { - fprintf(stderr, "out of stack space\n"); - exit(70); - } + if (top+16 >= INIT_STACK_SIZE) + errx(70, "out of stack space\n"); #endif i = sexp_unbox_integer(_WORD0); tmp1 = _ARG1; @@ -1752,19 +1753,19 @@ sexp sexp_vm (sexp ctx, sexp proc) { break; case OP_DISPLAY: if (sexp_stringp(_ARG1)) { - sexp_write_string(sexp_string_data(_ARG1), _ARG2); + sexp_write_string(ctx, sexp_string_data(_ARG1), _ARG2); _ARG2 = SEXP_VOID; top--; break; } else if (sexp_charp(_ARG1)) { - sexp_write_char(sexp_unbox_character(_ARG1), _ARG2); + sexp_write_char(ctx, sexp_unbox_character(_ARG1), _ARG2); _ARG2 = SEXP_VOID; top--; break; } /* ... FALLTHROUGH ... */ case OP_WRITE: - sexp_write(_ARG1, _ARG2); + sexp_write(ctx, _ARG1, _ARG2); _ARG2 = SEXP_VOID; top--; break; @@ -1774,7 +1775,7 @@ sexp sexp_vm (sexp ctx, sexp proc) { top--; break; case OP_NEWLINE: - sexp_write_char('\n', _ARG1); + sexp_write_char(ctx, '\n', _ARG1); _ARG1 = SEXP_VOID; break; case OP_FLUSH_OUTPUT: @@ -1787,12 +1788,12 @@ sexp sexp_vm (sexp ctx, sexp proc) { sexp_check_exception(); break; case OP_READ_CHAR: - i = sexp_read_char(_ARG1); + i = sexp_read_char(ctx, _ARG1); _ARG1 = (i == EOF) ? SEXP_EOF : sexp_make_character(i); break; case OP_PEEK_CHAR: - i = sexp_read_char(_ARG1); - sexp_push_char(i, _ARG1); + i = sexp_read_char(ctx, _ARG1); + sexp_push_char(ctx, i, _ARG1); _ARG1 = (i == EOF) ? SEXP_EOF : sexp_make_character(i); break; case OP_RET: @@ -1850,9 +1851,14 @@ static sexp sexp_open_output_file (sexp ctx, sexp path) { } static sexp sexp_close_port (sexp ctx, sexp port) { - fclose(sexp_port_stream(port)); + if (! sexp_portp(port)) + return sexp_type_exception(ctx, "not a port", port); + if (! sexp_port_openp(port)) + return sexp_user_exception(ctx, SEXP_FALSE, "port already closed", port); if (sexp_port_buf(port)) free(sexp_port_buf(port)); + if (sexp_port_stream(port)) + fclose(sexp_port_stream(port)); return SEXP_VOID; } @@ -1860,9 +1866,9 @@ void sexp_warn_undefs (sexp from, sexp to, sexp out) { sexp x; for (x=from; sexp_pairp(x) && x!=to; x=sexp_cdr(x)) if (sexp_cdar(x) == SEXP_UNDEF) { - sexp_write_string("WARNING: reference to undefined variable: ", out); - sexp_write(sexp_caar(x), out); - sexp_write_char('\n', out); + sexp_write_string(ctx, "WARNING: reference to undefined variable: ", out); + sexp_write(ctx, sexp_caar(x), out); + sexp_write_char(ctx, '\n', out); } } @@ -1960,25 +1966,6 @@ static sexp sexp_expt (sexp ctx, sexp x, sexp e) { return sexp_make_integer((sexp_sint_t)round(res)); } -static sexp sexp_string_concatenate (sexp ctx, sexp str_ls) { - sexp res, ls; - sexp_uint_t len=0; - char *p; - for (ls=str_ls; sexp_pairp(ls); ls=sexp_cdr(ls)) - if (! sexp_stringp(sexp_car(ls))) - return sexp_type_exception(ctx, "not a string", sexp_car(ls)); - else - len += sexp_string_length(sexp_car(ls)); - res = sexp_make_string(ctx, sexp_make_integer(len), SEXP_VOID); - p = sexp_string_data(res); - for (ls=str_ls; sexp_pairp(ls); ls=sexp_cdr(ls)) { - len = sexp_string_length(sexp_car(ls)); - memcpy(p, sexp_string_data(sexp_car(ls)), len); - p += len; - } - return res; -} - static sexp sexp_string_cmp (sexp ctx, sexp str1, sexp str2, sexp ci) { sexp_sint_t len1, len2, len, diff; if (! sexp_stringp(str1)) @@ -2153,6 +2140,7 @@ sexp sexp_eval (sexp ctx, sexp obj) { return res; } +#if USE_STRING_STREAMS sexp sexp_eval_string (sexp ctx, char *str) { sexp res; sexp_gc_var(ctx, obj, s_obj); @@ -2162,6 +2150,7 @@ sexp sexp_eval_string (sexp ctx, char *str) { sexp_gc_release(ctx, obj, s_obj); return res; } +#endif void sexp_scheme_init () { sexp ctx; diff --git a/gc.c b/gc.c index c8a980f3..caee6213 100644 --- a/gc.c +++ b/gc.c @@ -157,10 +157,8 @@ sexp sexp_gc (sexp ctx, size_t *sum_freed) { sexp_heap sexp_make_heap (size_t size) { sexp free, next; sexp_heap h = (sexp_heap) malloc(sizeof(struct sexp_heap) + size); - if (! h) { - fprintf(stderr, "out of memory allocating %zu byte heap, aborting\n", size); - exit(70); - } + if (! h) + errx(70, "out of memory allocating %zu byte heap, aborting\n", size); h->size = size; h->data = (char*) sexp_heap_align((sexp_uint_t)&(h->data)); free = h->free_list = (sexp) h->data; @@ -201,7 +199,7 @@ void* sexp_try_alloc (sexp ctx, size_t size) { } else { /* take the whole chunk */ sexp_cdr(ls1) = sexp_cdr(ls2); } - bzero((void*)ls2, size); + memset((void*)ls2, 0, size); return ls2; } ls1 = ls2; @@ -225,10 +223,8 @@ void* sexp_alloc (sexp ctx, size_t size) { && ((! SEXP_MAXIMUM_HEAP_SIZE) || (size < SEXP_MAXIMUM_HEAP_SIZE))) sexp_grow_heap(ctx, size); res = sexp_try_alloc(ctx, size); - if (! res) { - fprintf(stderr, "out of memory allocating %zu bytes, aborting\n", size); - exit(70); - } + if (! res) + errx(80, "out of memory allocating %zu bytes, aborting\n", size); } return res; } diff --git a/include/chibi/config.h b/include/chibi/config.h index 49661145..e3fdf9b6 100644 --- a/include/chibi/config.h +++ b/include/chibi/config.h @@ -42,13 +42,6 @@ /* DEFAULTS - DO NOT MODIFY ANYTHING BELOW THIS LINE */ /************************************************************************/ -#if HAVE_ERR_H -#include -#else -/* requires msg be a string literal, and at least one argument */ -#define errx(code, msg, ...) (fprintf(stderr,msg"\n",__VA_ARGS__), exit(code)) -#endif - #if defined(__APPLE__) || defined(__FreeBSD__) || defined(__NetBSD__) || defined(__DragonFly__) || defined(__OpenBSD__) #define SEXP_BSD 1 #else @@ -104,3 +97,24 @@ #define USE_CHECK_STACK 0 #endif +#ifdef PLAN9 + +#define errx(code, msg, ...) exits(msg) +#define exit_normally() exits(NULL) +#define strcasecmp cistrcmp +#define strncasecmp cistrncmp +/* XXXX these are wrong */ +#define trunc floor +#define round(x) floor(x+0.5) + +#else + +#define exit_normally() exit(0) +#if HAVE_ERR_H +#include +#else +/* requires msg be a string literal, and at least one argument */ +#define errx(code, msg, ...) (fprintf(stderr,msg"\n",__VA_ARGS__), exit(code)) +#endif + +#endif diff --git a/include/chibi/eval.h b/include/chibi/eval.h index dcee8420..9f0b26ea 100644 --- a/include/chibi/eval.h +++ b/include/chibi/eval.h @@ -5,7 +5,7 @@ #ifndef SEXP_EVAL_H #define SEXP_EVAL_H -#include "sexp.h" +#include "chibi/sexp.h" /************************* additional types ***************************/ diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 788d4a12..f3b8068d 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -5,17 +5,22 @@ #ifndef SEXP_H #define SEXP_H -#include "config.h" -#include "install.h" +#include "chibi/config.h" +#include "chibi/install.h" #include #include +#ifdef PLAN9 +typedef unsigned long size_t; +#define offsetof(st, m) ((size_t) ((char*)&((st*)(0))->m - (char*)0)) +#else #include #include #include #include #include #include +#endif /* tagging system * bits end in 00: pointer @@ -123,7 +128,7 @@ struct sexp_struct { struct { FILE *stream; char *buf; - sexp_uint_t line; + sexp_uint_t offset, line, openp; size_t size; sexp name; sexp cookie; @@ -366,9 +371,11 @@ sexp sexp_make_flonum(sexp ctx, double f); #define sexp_port_stream(p) ((p)->value.port.stream) #define sexp_port_name(p) ((p)->value.port.name) #define sexp_port_line(p) ((p)->value.port.line) +#define sexp_port_openp(p) ((p)->value.port.openp) #define sexp_port_cookie(p) ((p)->value.port.cookie) #define sexp_port_buf(p) ((p)->value.port.buf) #define sexp_port_size(p) ((p)->value.port.size) +#define sexp_port_offset(p) ((p)->value.port.offset) #define sexp_exception_kind(p) ((p)->value.exception.kind) #define sexp_exception_message(p) ((p)->value.exception.message) @@ -509,13 +516,32 @@ sexp sexp_make_flonum(sexp ctx, double f); /***************************** general API ****************************/ -#define sexp_read_char(p) (getc(sexp_port_stream(p))) -#define sexp_push_char(c, p) (ungetc(c, sexp_port_stream(p))) -#define sexp_write_char(c, p) (putc(c, sexp_port_stream(p))) -#define sexp_write_string(s, p) (fputs(s, sexp_port_stream(p))) -#define sexp_printf(p, ...) (fprintf(sexp_port_stream(p), __VA_ARGS__)) -#define sexp_scanf(p, ...) (fscanf(sexp_port_stream(p), __VA_ARGS__)) -#define sexp_flush(p) (fflush(sexp_port_stream(p))) +#if USE_STRING_STREAMS + +#define sexp_read_char(x, p) (getc(sexp_port_stream(p))) +#define sexp_push_char(x, c, p) (ungetc(c, sexp_port_stream(p))) +#define sexp_write_char(x, c, p) (putc(c, sexp_port_stream(p))) +#define sexp_write_string(x, s, p) (fputs(s, sexp_port_stream(p))) +#define sexp_printf(x, p, ...) (fprintf(sexp_port_stream(p), __VA_ARGS__)) +#define sexp_flush(x, p) (fflush(sexp_port_stream(p))) + +#else + +#define sexp_read_char(x, p) ((sexp_port_offset(p) < sexp_port_size(p)) ? sexp_port_buf(p)[sexp_port_offset(p)++] : sexp_buffered_read_char(x, p)) +#define sexp_push_char(x, c, p) (sexp_port_buf(p)[--sexp_port_offset(p)] = ((char)(c))) +#define sexp_write_char(x, c, p) ((sexp_port_offset(p) < sexp_port_size(p)) ? (((sexp_port_buf(p))[sexp_port_offset(p)++]) = ((char)(c))) : sexp_buffered_write_char(x, c, p)) +#define sexp_write_string(x, s, p) sexp_buffered_write_string(x, s, p) +#define sexp_flush(x, p) sexp_buffered_flush(x, p) + +int sexp_buffered_read_char (sexp ctx, sexp p); +sexp sexp_buffered_write_char (sexp ctx, int c, sexp p); +sexp sexp_buffered_write_string_n (sexp ctx, char *str, int len, sexp p); +sexp sexp_buffered_write_string (sexp ctx, char *str, sexp p); +sexp sexp_buffered_flush (sexp ctx, sexp p); + +#endif + +#define sexp_newline(p) sexp_write_char('\n', (p)) sexp sexp_alloc_tagged(sexp ctx, size_t size, sexp_uint_t tag); sexp sexp_cons(sexp ctx, sexp head, sexp tail); @@ -531,12 +557,13 @@ sexp sexp_length(sexp ctx, sexp ls); sexp sexp_c_string(sexp ctx, char *str, sexp_sint_t slen); sexp sexp_make_string(sexp ctx, sexp len, sexp ch); sexp sexp_substring (sexp ctx, sexp str, sexp start, sexp end); +sexp sexp_string_concatenate (sexp ctx, sexp str_ls); sexp sexp_intern(sexp ctx, char *str); sexp sexp_string_to_symbol(sexp ctx, sexp str); sexp sexp_make_vector(sexp ctx, sexp len, sexp dflt); sexp sexp_list_to_vector(sexp ctx, sexp ls); -sexp sexp_vector(sexp ctx, int count, ...); -void sexp_write(sexp obj, sexp out); +/* sexp sexp_vector(sexp ctx, int count, ...); */ +void sexp_write(sexp ctx, sexp obj, sexp out); sexp sexp_read_string(sexp ctx, sexp in); sexp sexp_read_symbol(sexp ctx, sexp in, int init, int internp); sexp sexp_read_number(sexp ctx, sexp in, int base); diff --git a/main.c b/main.c index 42f2d858..5e844ade 100644 --- a/main.c +++ b/main.c @@ -2,7 +2,9 @@ /* Copyright (c) 2009 Alex Shinn. All rights reserved. */ /* BSD-style license: http://synthcode.com/license.txt */ +#ifndef PLAN9 #include +#endif #include "chibi/eval.h" char *chibi_module_dir = NULL; @@ -11,13 +13,18 @@ sexp find_module_file (sexp ctx, char *file) { sexp res; int mlen, flen; char *path; +#ifndef PLAN9 struct stat buf; if (! stat(file, &buf)) +#endif return sexp_c_string(ctx, file, -1); +#ifndef PLAN9 if (! chibi_module_dir) { +#ifndef PLAN9 chibi_module_dir = getenv("CHIBI_MODULE_DIR"); if (! chibi_module_dir) +#endif chibi_module_dir = sexp_module_dir; } mlen = strlen(chibi_module_dir); @@ -33,6 +40,7 @@ sexp find_module_file (sexp ctx, char *file) { res = SEXP_FALSE; free(path); return res; +#endif } void repl (sexp ctx) { @@ -45,7 +53,7 @@ void repl (sexp ctx) { out = sexp_eval_string(ctx, "(current-output-port)"); err = sexp_eval_string(ctx, "(current-error-port)"); while (1) { - sexp_write_string("> ", out); + sexp_write_string(ctx, "> ", out); sexp_flush(out); obj = sexp_read(ctx, in); if (obj == SEXP_EOF) @@ -60,8 +68,8 @@ void repl (sexp ctx) { sexp_warn_undefs(sexp_env_bindings(env), tmp, err); #endif if (res != SEXP_VOID) { - sexp_write(res, out); - sexp_write_char('\n', out); + sexp_write(ctx, res, out); + sexp_write_char(ctx, '\n', out); } } } @@ -92,8 +100,8 @@ void run_main (int argc, char **argv) { if (sexp_exceptionp(res)) { sexp_print_exception(ctx, res, out); } else if (argv[i][1] == 'p') { - sexp_write(res, out); - sexp_write_char('\n', out); + sexp_write(ctx, res, out); + sexp_write_char(ctx, '\n', out); } quit=1; i++; diff --git a/mkfile b/mkfile new file mode 100644 index 00000000..a7785b39 --- /dev/null +++ b/mkfile @@ -0,0 +1,37 @@ + include/chibi/install.h + +%.i: %.c include/chibi/install.h $HFILES + cpp $CPPFLAGS $stem.c > $target + +sexp.$O: sexp.i + $CC $CFLAGS -c -o $target sexp.i + +eval.$O: eval.i + $CC $CFLAGS -c -o $target eval.i + +main.$O: main.i + $CC $CFLAGS -c -o $target main.i + +chibi-scheme: sexp.$O eval.$O main.$O + $LD -o $target -l $prereq + +# sexp_make_integer(0))) { - sexp_write_string(" on line ", out); - sexp_write(sexp_exception_line(exn), out); + sexp_write_string(ctx, " on line ", out); + sexp_write(ctx, 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(ctx, " of file ", out); + sexp_write_string(ctx, sexp_string_data(sexp_exception_file(exn)), out); } - sexp_write_string(": ", out); - sexp_write_string(sexp_string_data(sexp_exception_message(exn)), out); + sexp_write_string(ctx, ": ", out); + sexp_write_string(ctx, sexp_string_data(sexp_exception_message(exn)), out); if (sexp_exception_irritants(exn) && 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); + sexp_write_string(ctx, ": ", out); + sexp_write(ctx, sexp_car(sexp_exception_irritants(exn)), out); + sexp_write_string(ctx, "\n", out); } else { - sexp_write_string("\n", out); + sexp_write_string(ctx, "\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_char('\n', out); + sexp_write_string(ctx, " ", out); + sexp_write(ctx, sexp_car(ls), out); + sexp_write_char(ctx, '\n', out); } } } else { - sexp_write_char('\n', out); + sexp_write_char(ctx, '\n', out); } } else { - sexp_write_string(": ", out); + sexp_write_string(ctx, ": ", out); if (sexp_stringp(exn)) - sexp_write_string(sexp_string_data(exn), out); + sexp_write_string(ctx, sexp_string_data(exn), out); else - sexp_write(exn, out); - sexp_write_char('\n', out); + sexp_write(ctx, exn, out); + sexp_write_char(ctx, '\n', out); } return SEXP_VOID; } @@ -434,6 +434,25 @@ sexp sexp_substring (sexp ctx, sexp str, sexp start, sexp end) { return res; } +sexp sexp_string_concatenate (sexp ctx, sexp str_ls) { + sexp res, ls; + sexp_uint_t len=0; + char *p; + for (ls=str_ls; sexp_pairp(ls); ls=sexp_cdr(ls)) + if (! sexp_stringp(sexp_car(ls))) + return sexp_type_exception(ctx, "not a string", sexp_car(ls)); + else + len += sexp_string_length(sexp_car(ls)); + res = sexp_make_string(ctx, sexp_make_integer(len), SEXP_VOID); + p = sexp_string_data(res); + for (ls=str_ls; sexp_pairp(ls); ls=sexp_cdr(ls)) { + len = sexp_string_length(sexp_car(ls)); + memcpy(p, sexp_string_data(sexp_car(ls)), len); + p += len; + } + return res; +} + #define FNV_PRIME 16777619 #define FNV_OFFSET_BASIS 2166136261uL @@ -513,19 +532,6 @@ sexp sexp_list_to_vector(sexp ctx, sexp ls) { return vec; } -sexp sexp_vector(sexp ctx, int count, ...) { - sexp vec = sexp_make_vector(ctx, sexp_make_integer(count), SEXP_VOID); - sexp *elts = sexp_vector_data(vec); - va_list ap; - int i; - - va_start(ap, count); - for (i=0; i= sexp_port_size(p)) + sexp_buffered_flush(ctx, p); + sexp_port_buf(p)[sexp_port_offset(p)++] = (c); + return SEXP_VOID; +} + +sexp sexp_buffered_write_string_n (sexp ctx, char *str, sexp_uint_t len, sexp p) { + if (sexp_port_offset(p) >= sexp_port_size(p)) + sexp_buffered_flush(ctx, p); + memcpy(sexp_port_buf(p)+sexp_port_offset(p), str, len); + sexp_port_offset(p) += len; + return SEXP_VOID; +} + +sexp sexp_buffered_write_string (sexp ctx, char *str, sexp p) { + return sexp_buffered_write_string_n(str, strlen(str), p); +} + +sexp sexp_buffered_flush (sexp ctx, sexp p) { + sexp_gc_var(ctx, tmp, s_tmp); + sexp_gc_preserve(ctx, tmp, s_tmp); +/* if (! sexp_oportp(p)) */ +/* return sexp_type_exception(); */ +/* else if (! sexp_port_openp(p)) */ +/* return sexp_make_exception(); */ +/* else { */ + if (sexp_port_stream(p)) { + fwrite(sexp_port_buf(p), 1, sexp_port_offset(p), sexp_port_stream(p)); + sexp_port_offset(p) = 0; + fflush(sexp_port_stream(p)); + } else if (sexp_port_offset(p) > 0) { + tmp = sexp_c_string(ctx, sexp_port_buf(p), sexp_port_offset(p)); + sexp_push(ctx, sexp_port_cookie(p), tmp); + sexp_port_offset(p) = 0; + } + sexp_gc_release(ctx, tmp, s_tmp); + return SEXP_VOID; +/* } */ +} + +sexp sexp_make_input_string_port (sexp ctx, sexp str) { + sexp res = sexp_make_input_port(ctx, NULL, SEXP_FALSE); + sexp_port_cookie(res) = str; + sexp_port_buf(res) = sexp_string_data(str); + sexp_port_offset(res) = 0; + sexp_port_size(res) = sexp_string_length(str); + return res; +} + +sexp sexp_make_output_string_port (sexp ctx) { + sexp res = sexp_make_output_port(ctx, NULL, SEXP_FALSE); + sexp_port_buf(res) = (char*) malloc(SEXP_PORT_BUFFER_SIZE); + sexp_port_size(res) = SEXP_PORT_BUFFER_SIZE; + sexp_port_offset(res) = 0; + sexp_port_cookie(res) = SEXP_NULL; + return res; +} + +sexp sexp_get_output_string (sexp ctx, sexp out) { + sexp res; + sexp_gc_var(ctx, tmp, s_tmp); + sexp_gc_preserve(ctx, tmp, s_tmp); + tmp = ((sexp_port_offset(out) > 0) + ? sexp_cons(ctx, + tmp=sexp_c_string(ctx, + sexp_port_buf(out), + sexp_port_offset(out)), + sexp_port_cookie(out)) + : sexp_port_cookie(out)); + res = sexp_string_concatenate(ctx, tmp); + sexp_gc_release(ctx, tmp, s_tmp); + return res; +} + #endif sexp sexp_make_input_port (sexp ctx, FILE* in, sexp name) { @@ -652,6 +751,7 @@ sexp sexp_make_input_port (sexp ctx, FILE* in, sexp name) { sexp_port_stream(p) = in; sexp_port_name(p) = name; sexp_port_line(p) = 0; + sexp_port_openp(p) = 1; return p; } @@ -661,187 +761,205 @@ sexp sexp_make_output_port (sexp ctx, FILE* out, sexp name) { sexp_port_name(p) = name; sexp_port_line(p) = 0; sexp_port_buf(p) = NULL; + sexp_port_openp(p) = 1; return p; } -void sexp_write (sexp obj, sexp out) { +void sexp_write (sexp ctx, sexp obj, sexp out) { unsigned long len, c, res; long i=0; double f; sexp x, *elts; - char *str=NULL; + char *str=NULL, numbuf[20]; if (! obj) { - sexp_write_string("#", out); /* shouldn't happen */ + sexp_write_string(ctx, "#", out); /* shouldn't happen */ } else if (sexp_pointerp(obj)) { switch (sexp_pointer_tag(obj)) { case SEXP_PAIR: - sexp_write_char('(', out); - sexp_write(sexp_car(obj), out); + sexp_write_char(ctx, '(', out); + sexp_write(ctx, 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); + sexp_write_char(ctx, ' ', out); + sexp_write(ctx, sexp_car(x), out); } if (! sexp_nullp(x)) { - sexp_write_string(" . ", out); - sexp_write(x, out); + sexp_write_string(ctx, " . ", out); + sexp_write(ctx, x, out); } - sexp_write_char(')', out); + sexp_write_char(ctx, ')', out); break; case SEXP_VECTOR: len = sexp_vector_length(obj); elts = sexp_vector_data(obj); if (len == 0) { - sexp_write_string("#()", out); + sexp_write_string(ctx, "#()", out); } else { - sexp_write_string("#(", out); - sexp_write(elts[0], out); + sexp_write_string(ctx, "#(", out); + sexp_write(ctx, elts[0], out); for (i=1; i", out); + sexp_write_string(ctx, "#", out); break; case SEXP_IPORT: - sexp_write_string("#", out); break; + sexp_write_string(ctx, "#", out); break; case SEXP_OPORT: - sexp_write_string("#", out); break; + sexp_write_string(ctx, "#", out); break; case SEXP_CORE: - sexp_write_string("#", out); break; + sexp_write_string(ctx, "#", out); break; case SEXP_OPCODE: - sexp_write_string("#", out); break; + sexp_write_string(ctx, "#", out); break; case SEXP_BYTECODE: - sexp_write_string("#", out); break; + sexp_write_string(ctx, "#", out); break; case SEXP_ENV: - sexp_printf(out, "# 5) { - sexp_write_char(' ', out); - sexp_write(sexp_caar(x), out); - sexp_write_string(": ", out); - if ((! sexp_cdar(x)) || sexp_pointerp(sexp_cdar(x))) - sexp_printf(out, "%p", sexp_cdar(x)); - else - sexp_write(sexp_cdar(x), out); - sexp_write_string(" ...", out); - } else for ( ; x && sexp_pairp(x); x=sexp_cdr(x)) { - sexp_write_char(' ', out); - sexp_write(sexp_caar(x), out); - sexp_write_string(": ", out); - if ((! sexp_cdar(x)) || sexp_pointerp(sexp_cdar(x))) - sexp_printf(out, "%p", sexp_cdar(x)); - else - sexp_write(sexp_cdar(x), out); - } - sexp_write_char('>', out); + sexp_write_string(ctx, "#", out); break; +/* sexp_printf(out, "# 5) { */ +/* sexp_write_char(' ', out); */ +/* sexp_write(sexp_caar(x), out); */ +/* sexp_write_string(": ", out); */ +/* if ((! sexp_cdar(x)) || sexp_pointerp(sexp_cdar(x))) */ +/* sexp_printf(out, "%p", sexp_cdar(x)); */ +/* else */ +/* sexp_write(sexp_cdar(x), out); */ +/* sexp_write_string(" ...", out); */ +/* } else for ( ; x && sexp_pairp(x); x=sexp_cdr(x)) { */ +/* sexp_write_char(' ', out); */ +/* sexp_write(sexp_caar(x), out); */ +/* sexp_write_string(": ", out); */ +/* if ((! sexp_cdar(x)) || sexp_pointerp(sexp_cdar(x))) */ +/* sexp_printf(out, "%p", sexp_cdar(x)); */ +/* else */ +/* sexp_write(sexp_cdar(x), out); */ +/* } */ +/* sexp_write_char('>', out); */ break; case SEXP_EXCEPTION: - sexp_write_string("#", out); break; + sexp_write_string(ctx, "#", out); break; case SEXP_MACRO: - sexp_write_string("#", out); break; + sexp_write_string(ctx, "#", out); break; #if USE_DEBUG case SEXP_LAMBDA: - /* sexp_write_string("#', out); + sexp_write_string(ctx, "#', out); */ break; case SEXP_SEQ: - sexp_write_string("#', out); + sexp_write_string(ctx, "#', out); break; case SEXP_CND: - sexp_write_string("#', out); + sexp_write_string(ctx, "#', out); break; case SEXP_REF: - sexp_write_string("#", sexp_ref_loc(obj)); + sexp_write_string(ctx, "#", out); +/* sexp_write_string("#", sexp_ref_loc(obj)); */ break; case SEXP_SET: - sexp_write_string("#", out); + sexp_write_string(ctx, "#", out); break; case SEXP_SYNCLO: - sexp_write_string("#", out); + sexp_write_string(ctx, "#", out); break; #endif case SEXP_TYPE: - sexp_write_string("#", out); + sexp_write_string(ctx, "#", out); break; case SEXP_STRING: - sexp_write_char('"', out); + sexp_write_char(ctx, '"', out); i = sexp_string_length(obj); str = sexp_string_data(obj); for ( ; i>0; str++, i--) { switch (str[0]) { - case '\\': sexp_write_string("\\\\", out); break; - case '"': sexp_write_string("\\\"", out); break; - case '\n': sexp_write_string("\\n", out); break; - case '\r': sexp_write_string("\\r", out); break; - case '\t': sexp_write_string("\\t", out); break; - default: sexp_write_char(str[0], out); + case '\\': sexp_write_string(ctx, "\\\\", out); break; + case '"': sexp_write_string(ctx, "\\\"", out); break; + case '\n': sexp_write_string(ctx, "\\n", out); break; + case '\r': sexp_write_string(ctx, "\\r", out); break; + case '\t': sexp_write_string(ctx, "\\t", out); break; + default: sexp_write_char(ctx, str[0], out); } } - sexp_write_char('"', out); + sexp_write_char(ctx, '"', out); break; case SEXP_SYMBOL: i = sexp_string_length(sexp_symbol_string(obj)); str = sexp_string_data(sexp_symbol_string(obj)); for ( ; i>0; str++, i--) { if ((str[0] == '\\') || is_separator(str[0])) - sexp_write_char('\\', out); - sexp_write_char(str[0], out); + sexp_write_char(ctx, '\\', out); + sexp_write_char(ctx, str[0], out); } break; } } else if (sexp_integerp(obj)) { - sexp_printf(out, "%ld", sexp_unbox_integer(obj)); + sprintf(numbuf, "%ld", sexp_unbox_integer(obj)); + sexp_write_string(ctx, numbuf, out); #if USE_IMMEDIATE_FLONUMS } else if (sexp_flonump(obj)) { f = sexp_flonum_value(obj); - sexp_printf(out, "%.15g%s", f, (f == trunc(f)) ? ".0" : ""); + i = sprintf(numbuf, "%.15g", f); + if (f == trunc(f)) { + numbuf[i++] = '.'; numbuf[i++] = '0'; numbuf[i++] = '\0'; + } + sexp_write_string(ctx, numbuf, out); #endif } else if (sexp_charp(obj)) { if (obj == sexp_make_character(' ')) - sexp_write_string("#\\space", out); + sexp_write_string(ctx, "#\\space", out); else if (obj == sexp_make_character('\n')) - sexp_write_string("#\\newline", out); + sexp_write_string(ctx, "#\\newline", out); else if (obj == sexp_make_character('\r')) - sexp_write_string("#\\return", out); + sexp_write_string(ctx, "#\\return", out); else if (obj == sexp_make_character('\t')) - sexp_write_string("#\\tab", out); + sexp_write_string(ctx, "#\\tab", out); else 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)); + sexp_write_char(ctx, sexp_unbox_character(obj), out); + else { + sexp_write_string(ctx, "#\\x", out); + if (sexp_unbox_character(obj) < 16) + sexp_write_char(ctx, '0', out); + sexp_write(ctx, sexp_make_integer(sexp_unbox_character(obj)), out); + } } else if (sexp_symbolp(obj)) { #if USE_HUFF_SYMS @@ -849,7 +967,7 @@ void sexp_write (sexp obj, sexp out) { c = ((sexp_uint_t)obj)>>3; while (c) { #include "opt/sexp-unhuff.c" - sexp_write_char(res, out); + sexp_write_char(ctx, res, out); } } #endif @@ -857,18 +975,18 @@ void sexp_write (sexp obj, sexp out) { } else { switch ((sexp_uint_t) obj) { case (sexp_uint_t) SEXP_NULL: - sexp_write_string("()", out); break; + sexp_write_string(ctx, "()", out); break; case (sexp_uint_t) SEXP_TRUE: - sexp_write_string("#t", out); break; + sexp_write_string(ctx, "#t", out); break; case (sexp_uint_t) SEXP_FALSE: - sexp_write_string("#f", out); break; + sexp_write_string(ctx, "#f", out); break; case (sexp_uint_t) SEXP_EOF: - sexp_write_string("#", out); break; + sexp_write_string(ctx, "#", out); break; case (sexp_uint_t) SEXP_UNDEF: case (sexp_uint_t) SEXP_VOID: - sexp_write_string("#", out); break; + sexp_write_string(ctx, "#", out); break; default: - sexp_printf(out, "#", obj); + sexp_write_string(ctx, "#", out); } } } @@ -881,9 +999,9 @@ sexp sexp_read_string(sexp ctx, sexp in) { char *buf=initbuf, *tmp; sexp res; - for (c = sexp_read_char(in); c != '"'; c = sexp_read_char(in)) { + for (c = sexp_read_char(ctx, in); c != '"'; c = sexp_read_char(ctx, in)) { if (c == '\\') { - c = sexp_read_char(in); + c = sexp_read_char(ctx, in); switch (c) {case 'n': c = '\n'; break; case 't': c = '\t'; break;} } if (c == EOF) { @@ -892,7 +1010,7 @@ sexp sexp_read_string(sexp ctx, sexp in) { } buf[i++] = c; if (i >= size) { /* expand buffer w/ malloc(), later free() it */ - tmp = malloc(size*2); + tmp = (char*) malloc(size*2); memcpy(tmp, buf, i); if (size != INIT_STRING_BUFFER_SIZE) free(buf); buf = tmp; @@ -915,15 +1033,15 @@ sexp sexp_read_symbol(sexp ctx, sexp in, int init, int internp) { if (init != EOF) buf[i++] = init; - for (c = sexp_read_char(in); c != '"'; c = sexp_read_char(in)) { - if (c == '\\') c = sexp_read_char(in); + for (c = sexp_read_char(ctx, in); c != '"'; c = sexp_read_char(ctx, in)) { + if (c == '\\') c = sexp_read_char(ctx, in); if (c == EOF || is_separator(c)) { - sexp_push_char(c, in); + sexp_push_char(ctx, c, in); break; } buf[i++] = c; if (i >= size) { /* expand buffer w/ malloc(), later free() it */ - tmp = malloc(size*2); + tmp = (char*) malloc(size*2); memcpy(tmp, buf, i); if (size != INIT_STRING_BUFFER_SIZE) free(buf); buf = tmp; @@ -941,9 +1059,11 @@ sexp sexp_read_float_tail(sexp ctx, sexp in, sexp_sint_t whole) { sexp exponent; double res=0.0, scale=0.1, e=0.0; int c; - for (c=sexp_read_char(in); isdigit(c); c=sexp_read_char(in), scale*=0.1) + for (c=sexp_read_char(ctx, in); + isdigit(c); + c=sexp_read_char(ctx, in), scale*=0.1) res += digit_value(c)*scale; - sexp_push_char(c, in); + sexp_push_char(ctx, c, in); if (c=='e' || c=='E') { exponent = sexp_read_number(ctx, in, 10); if (sexp_exceptionp(exponent)) return exponent; @@ -959,23 +1079,24 @@ sexp sexp_read_number(sexp ctx, sexp in, int base) { sexp f; sexp_sint_t res = 0, negativep = 0, c; - c = sexp_read_char(in); + c = sexp_read_char(ctx, in); if (c == '-') negativep = 1; else if (isdigit(c)) res = digit_value(c); if (base == 16) - for (c=sexp_read_char(in); isxdigit(c); c=sexp_read_char(in)) + for (c=sexp_read_char(ctx, in); isxdigit(c); c=sexp_read_char(ctx, in)) res = res * base + digit_value(c); - for (c=sexp_read_char(in); isdigit(c); c=sexp_read_char(in)) + for (c=sexp_read_char(ctx, in); isdigit(c); c=sexp_read_char(ctx, in)) res = res * base + digit_value(c); if (c=='.' || c=='e' || c=='E') { if (base != 10) - return sexp_read_error(ctx, "decimal found in non-base 10", SEXP_NULL, in); + return + sexp_read_error(ctx, "decimal found in non-base 10", SEXP_NULL, in); if (c!='.') - sexp_push_char(c, in); + sexp_push_char(ctx, c, in); f = sexp_read_float_tail(ctx, in, res); if (! sexp_flonump(f)) return f; if ((c!='.') && (sexp_flonum_value(f) == round(sexp_flonum_value(f)))) { @@ -990,7 +1111,7 @@ sexp sexp_read_number(sexp ctx, sexp in, int base) { return f; } } else { - sexp_push_char(c, in); + sexp_push_char(ctx, c, in); if ((c!=EOF) && ! is_separator(c)) return sexp_read_error(ctx, "invalid numeric syntax", sexp_list1(ctx, sexp_make_character(c)), in); @@ -1009,13 +1130,13 @@ sexp sexp_read_raw (sexp ctx, sexp in) { sexp_gc_preserve(ctx, tmp, s_tmp); scan_loop: - switch (c1 = sexp_read_char(in)) { + switch (c1 = sexp_read_char(ctx, in)) { case EOF: res = SEXP_EOF; break; case ';': sexp_port_line(in)++; - while ((c1 = sexp_read_char(in)) != EOF) + while ((c1 = sexp_read_char(ctx, in)) != EOF) if (c1 == '\n') break; /* ... FALLTHROUGH ... */ @@ -1035,11 +1156,11 @@ sexp sexp_read_raw (sexp ctx, sexp in) { res = sexp_list2(ctx, the_quasiquote_symbol, res); break; case ',': - if ((c1 = sexp_read_char(in)) == '@') { + if ((c1 = sexp_read_char(ctx, in)) == '@') { res = sexp_read(ctx, in); res = sexp_list2(ctx, the_unquote_splicing_symbol, res); } else { - sexp_push_char(c1, in); + sexp_push_char(ctx, c1, in); res = sexp_read(ctx, in); res = sexp_list2(ctx, the_unquote_symbol, res); } @@ -1087,7 +1208,7 @@ sexp sexp_read_raw (sexp ctx, sexp in) { } break; case '#': - switch (c1=sexp_read_char(in)) { + switch (c1=sexp_read_char(ctx, in)) { case 'b': res = sexp_read_number(ctx, in, 2); break; case 'o': @@ -1108,10 +1229,10 @@ sexp sexp_read_raw (sexp ctx, sexp in) { break; case 'f': case 't': - c2 = sexp_read_char(in); + c2 = sexp_read_char(ctx, in); if (c2 == EOF || is_separator(c2)) { res = (c1 == 't' ? SEXP_TRUE : SEXP_FALSE); - sexp_push_char(c2, in); + sexp_push_char(ctx, c2, in); } else { res = sexp_read_error(ctx, "invalid syntax #%c%c", sexp_list2(ctx, @@ -1129,7 +1250,7 @@ sexp sexp_read_raw (sexp ctx, sexp in) { else goto scan_loop; case '\\': - c1 = sexp_read_char(in); + c1 = sexp_read_char(ctx, in); res = sexp_read_symbol(ctx, in, c1, 0); if (sexp_stringp(res)) { str = sexp_string_data(res); @@ -1160,7 +1281,7 @@ sexp sexp_read_raw (sexp ctx, sexp in) { } break; case '(': - sexp_push_char(c1, in); + sexp_push_char(ctx, c1, in); res = sexp_read(ctx, in); if (sexp_not(sexp_listp(ctx, res))) { if (! sexp_exceptionp(res)) { @@ -1178,14 +1299,14 @@ sexp sexp_read_raw (sexp ctx, sexp in) { } break; case '.': - c1 = sexp_read_char(in); + c1 = sexp_read_char(ctx, in); if (c1 == EOF || is_separator(c1)) { res = SEXP_RAWDOT; } else if (isdigit(c1)) { - sexp_push_char(c1,in ); + sexp_push_char(ctx, c1, in); res = sexp_read_float_tail(ctx, in, 0); } else { - sexp_push_char(c1, in); + sexp_push_char(ctx, c1, in); res = sexp_read_symbol(ctx, in, '.', 1); } break; @@ -1194,9 +1315,9 @@ sexp sexp_read_raw (sexp ctx, sexp in) { break; case '+': case '-': - c2 = sexp_read_char(in); + c2 = sexp_read_char(ctx, in); if (c2 == '.' || isdigit(c2)) { - sexp_push_char(c2, in); + sexp_push_char(ctx, c2, in); res = sexp_read_number(ctx, in, 10); if ((c1 == '-') && ! sexp_exceptionp(res)) { #if USE_FLONUMS @@ -1211,13 +1332,13 @@ sexp sexp_read_raw (sexp ctx, sexp in) { res = sexp_fx_mul(res, -1); } } else { - sexp_push_char(c2, in); + sexp_push_char(ctx, c2, in); res = sexp_read_symbol(ctx, in, c1, 1); } 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); + sexp_push_char(ctx, c1, in); res = sexp_read_number(ctx, in, 10); break; default: @@ -1238,7 +1359,6 @@ sexp sexp_read (sexp ctx, sexp in) { return res; } -#if USE_STRING_STREAMS sexp sexp_read_from_string(sexp ctx, char *str) { sexp res; sexp_gc_var(ctx, s, s_s); @@ -1251,7 +1371,6 @@ sexp sexp_read_from_string(sexp ctx, char *str) { sexp_gc_release(ctx, s, s_s); return res; } -#endif void sexp_init() { int i; From 32838c1f9b1617f423205d33cc6661928a951c0c Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 27 Jun 2009 23:46:03 +0900 Subject: [PATCH 142/154] only using our own buffering for string ports --- Makefile | 5 +++- debug.c | 16 +++++------ eval.c | 23 ++++++++-------- include/chibi/eval.h | 2 +- include/chibi/sexp.h | 20 +++++++------- main.c | 6 ++--- opcodes.c | 2 -- sexp.c | 63 +++++++++++++++++++++++--------------------- 8 files changed, 69 insertions(+), 68 deletions(-) diff --git a/Makefile b/Makefile index 05fbbc9c..edf7867a 100644 --- a/Makefile +++ b/Makefile @@ -24,7 +24,8 @@ SO = .dylib EXE = CLIBFLAGS = -dynamiclib STATICFLAGS = -static-libgcc -else ifeq ($(PLATFORM),mingw) +else +ifeq ($(PLATFORM),mingw) SO = .dll EXE = .exe CLIBFLAGS = -fPIC -shared @@ -34,6 +35,7 @@ EXE = CLIBFLAGS = -fPIC -shared STATICFLAGS = -static endif +endif ifdef USE_BOEHM GCLDFLAGS := -lgc @@ -90,6 +92,7 @@ test: chibi-scheme ./chibi-scheme tests/r5rs-tests.scm install: chibi-scheme + mkdir -p $(BINDIR) cp chibi-scheme $(BINDIR)/ mkdir -p $(MODDIR) cp init.scm $(MODDIR)/ diff --git a/debug.c b/debug.c index 8a03a8a8..d8a51689 100644 --- a/debug.c +++ b/debug.c @@ -28,9 +28,9 @@ static sexp sexp_disasm (sexp ctx, sexp bc, sexp out) { loop: opcode = *ip++; if (opcode*sizeof(char*) < sizeof(reverse_opcode_names)) { - sexp_printf(out, " %s ", reverse_opcode_names[opcode]); + sexp_printf(ctx, out, " %s ", reverse_opcode_names[opcode]); } else { - sexp_printf(out, " %d ", opcode); + sexp_printf(ctx, out, " %d ", opcode); } switch (opcode) { case OP_STACK_REF: @@ -44,7 +44,7 @@ static sexp sexp_disasm (sexp ctx, sexp bc, sexp out) { case OP_FCALL2: case OP_FCALL3: case OP_TYPEP: - sexp_printf(out, "%ld", (sexp_sint_t) ((sexp*)ip)[0]); + sexp_printf(ctx, out, "%ld", (sexp_sint_t) ((sexp*)ip)[0]); ip += sizeof(sexp); break; case OP_GLOBAL_REF: @@ -52,11 +52,11 @@ static sexp sexp_disasm (sexp ctx, sexp bc, sexp out) { case OP_TAIL_CALL: case OP_CALL: case OP_PUSH: - sexp_write(((sexp*)ip)[0], out); + sexp_write(ctx, ((sexp*)ip)[0], out); ip += sizeof(sexp); break; } - sexp_write_char('\n', out); + sexp_write_char(ctx, '\n', out); if (ip - sexp_bytecode_data(bc) < sexp_bytecode_length(bc)) goto loop; return SEXP_VOID; @@ -66,9 +66,9 @@ static sexp sexp_disasm (sexp ctx, sexp bc, sexp out) { static void sexp_print_stack (sexp *stack, int top, int fp, sexp out) { int i; for (i=0; i ", out); - sexp_flush(out); + sexp_flush(ctx, out); obj = sexp_read(ctx, in); if (obj == SEXP_EOF) break; @@ -65,7 +65,7 @@ void repl (sexp ctx) { sexp_context_top(ctx) = 0; res = sexp_eval(ctx, obj); #if USE_WARN_UNDEFS - sexp_warn_undefs(sexp_env_bindings(env), tmp, err); + sexp_warn_undefs(ctx, sexp_env_bindings(env), tmp, err); #endif if (res != SEXP_VOID) { sexp_write(ctx, res, out); @@ -89,7 +89,6 @@ void run_main (int argc, char **argv) { /* parse options */ for (i=1; i < argc && argv[i][0] == '-'; i++) { switch (argv[i][1]) { -#if USE_STRING_STREAMS case 'e': case 'p': if (! init_loaded++) @@ -106,7 +105,6 @@ void run_main (int argc, char **argv) { quit=1; i++; break; -#endif case 'l': if (! init_loaded++) sexp_load(ctx, str=find_module_file(ctx, sexp_init_file), env); diff --git a/opcodes.c b/opcodes.c index 33371854..52e75045 100644 --- a/opcodes.c +++ b/opcodes.c @@ -119,11 +119,9 @@ _FN1(0, "floor", 0, sexp_floor), _FN1(0, "ceiling", 0, sexp_ceiling), _FN2(0, 0, "expt", 0, sexp_expt), #endif -#if USE_STRING_STREAMS _FN0("open-output-string", 0, sexp_make_output_string_port), _FN1(SEXP_STRING, "open-input-string", 0, sexp_make_input_string_port), _FN1(SEXP_OPORT, "get-output-string", 0, sexp_get_output_string), -#endif #if USE_DEBUG _FN2(SEXP_PROCEDURE, SEXP_OPORT, "disasm", 0, sexp_disasm), #endif diff --git a/sexp.c b/sexp.c index 2279349a..ea0adbd9 100644 --- a/sexp.c +++ b/sexp.c @@ -594,9 +594,11 @@ sexp sexp_make_input_string_port (sexp ctx, sexp str) { sexp res; sexp_gc_var(ctx, cookie, s_cookie); sexp_gc_preserve(ctx, cookie, s_cookie); - cookie = sexp_vector(ctx, 4, ctx, str, - sexp_make_integer(sexp_string_length(str)), - sexp_make_integer(0)); + cookie = sexp_make_vector(ctx, sexp_make_integer(4), SEXP_VOID); + sexp_stream_ctx(cookie) = ctx; + sexp_stream_buf(cookie) = str; + sexp_stream_size(cookie) = sexp_make_integer(sexp_string_length(str)); + sexp_stream_pos(cookie) = sexp_make_integer(0); in = funopen(cookie, &sstream_read, NULL, &sstream_seek, NULL); res = sexp_make_input_port(ctx, in, SEXP_FALSE); sexp_port_cookie(res) = cookie; @@ -610,8 +612,11 @@ sexp sexp_make_output_string_port (sexp ctx) { sexp_gc_var(ctx, cookie, s_cookie); sexp_gc_preserve(ctx, cookie, s_cookie); size = sexp_make_integer(SEXP_INIT_STRING_PORT_SIZE); - cookie = sexp_vector(ctx, 4, ctx, sexp_make_string(ctx, size, SEXP_VOID), - size, sexp_make_integer(0)); + cookie = sexp_make_vector(ctx, sexp_make_integer(4), SEXP_VOID); + sexp_stream_ctx(cookie) = ctx; + sexp_stream_buf(cookie) = sexp_make_string(ctx, size, SEXP_VOID); + sexp_stream_size(cookie) = size; + sexp_stream_pos(cookie) = sexp_make_integer(0); out = funopen(cookie, NULL, &sstream_write, &sstream_seek, NULL); res = sexp_make_output_port(ctx, out, SEXP_FALSE); sexp_port_cookie(res) = cookie; @@ -672,7 +677,7 @@ int sexp_buffered_read_char (sexp ctx, sexp p) { sexp sexp_buffered_write_char (sexp ctx, int c, sexp p) { if (sexp_port_offset(p) >= sexp_port_size(p)) sexp_buffered_flush(ctx, p); - sexp_port_buf(p)[sexp_port_offset(p)++] = (c); + sexp_port_buf(p)[sexp_port_offset(p)++] = c; return SEXP_VOID; } @@ -685,29 +690,29 @@ sexp sexp_buffered_write_string_n (sexp ctx, char *str, sexp_uint_t len, sexp p) } sexp sexp_buffered_write_string (sexp ctx, char *str, sexp p) { - return sexp_buffered_write_string_n(str, strlen(str), p); + return sexp_buffered_write_string_n(ctx, str, strlen(str), p); } sexp sexp_buffered_flush (sexp ctx, sexp p) { sexp_gc_var(ctx, tmp, s_tmp); - sexp_gc_preserve(ctx, tmp, s_tmp); -/* if (! sexp_oportp(p)) */ -/* return sexp_type_exception(); */ -/* else if (! sexp_port_openp(p)) */ -/* return sexp_make_exception(); */ -/* else { */ - if (sexp_port_stream(p)) { - fwrite(sexp_port_buf(p), 1, sexp_port_offset(p), sexp_port_stream(p)); - sexp_port_offset(p) = 0; - fflush(sexp_port_stream(p)); - } else if (sexp_port_offset(p) > 0) { - tmp = sexp_c_string(ctx, sexp_port_buf(p), sexp_port_offset(p)); - sexp_push(ctx, sexp_port_cookie(p), tmp); - sexp_port_offset(p) = 0; + if (! sexp_oportp(p)) + return sexp_type_exception(ctx, "not an output-port", p); + else if (! sexp_port_openp(p)) + return sexp_user_exception(ctx, SEXP_FALSE, "port is closed", p); + else { + if (sexp_port_stream(p)) { + fwrite(sexp_port_buf(p), 1, sexp_port_offset(p), sexp_port_stream(p)); + sexp_port_offset(p) = 0; + fflush(sexp_port_stream(p)); + } else if (sexp_port_offset(p) > 0) { + sexp_gc_preserve(ctx, tmp, s_tmp); + tmp = sexp_c_string(ctx, sexp_port_buf(p), sexp_port_offset(p)); + sexp_push(ctx, sexp_port_cookie(p), tmp); + sexp_port_offset(p) = 0; + sexp_gc_release(ctx, tmp, s_tmp); + } + return SEXP_VOID; } - sexp_gc_release(ctx, tmp, s_tmp); - return SEXP_VOID; -/* } */ } sexp sexp_make_input_string_port (sexp ctx, sexp str) { @@ -751,17 +756,15 @@ sexp sexp_make_input_port (sexp ctx, FILE* in, sexp name) { sexp_port_stream(p) = in; sexp_port_name(p) = name; sexp_port_line(p) = 0; + sexp_port_buf(p) = NULL; sexp_port_openp(p) = 1; + sexp_port_cookie(p) = SEXP_VOID; return p; } sexp sexp_make_output_port (sexp ctx, FILE* out, sexp name) { - sexp p = sexp_alloc_type(ctx, port, SEXP_OPORT); - sexp_port_stream(p) = out; - sexp_port_name(p) = name; - sexp_port_line(p) = 0; - sexp_port_buf(p) = NULL; - sexp_port_openp(p) = 1; + sexp p = sexp_make_input_port(ctx, out, name); + sexp_pointer_tag(p) = SEXP_OPORT; return p; } From baa8b07d6398e71f8741e9f1bde9c85c07875320 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 27 Jun 2009 23:54:48 +0900 Subject: [PATCH 143/154] don't want -l in link rule for chibi-scheme --- mkfile | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/mkfile b/mkfile index a7785b39..4de142a2 100644 --- a/mkfile +++ b/mkfile @@ -4,8 +4,7 @@ BIN=/$objtype/bin TARG=chibi-scheme MODDIR=/sys/lib/chibi-scheme -#CC=pcc -CPPFLAGS= -Iinclude -DPLAN9 -DUSE_STRING_STREAMS=0 +CPPFLAGS= -Iinclude -DPLAN9 -DUSE_STRING_STREAMS=0 -DUSE_DEBUG=0 CFLAGS= -c -B $CPPFLAGS OFILES=sexp.$O eval.$O main.$O @@ -28,7 +27,7 @@ main.$O: main.i $CC $CFLAGS -c -o $target main.i chibi-scheme: sexp.$O eval.$O main.$O - $LD -o $target -l $prereq + $LD -o $target $prereq # Date: Sun, 28 Jun 2009 01:48:12 +0900 Subject: [PATCH 144/154] need to close string ports --- init.scm | 9 +++++++-- sexp.c | 28 +++++++++++++++------------- 2 files changed, 22 insertions(+), 15 deletions(-) diff --git a/init.scm b/init.scm index 72ecb2b1..08d321c1 100644 --- a/init.scm +++ b/init.scm @@ -480,12 +480,17 @@ (define (load file) (%load file (interaction-environment))) (define (call-with-input-string str proc) - (proc (open-input-string str))) + (let* ((in (open-input-string str)) + (res (proc in))) + (close-input-port in) + res)) (define (call-with-output-string proc) (let ((out (open-output-string))) (proc out) - (get-output-string out))) + (let ((res (get-output-string out))) + (close-output-port out) + res))) (define (call-with-input-file file proc) (let* ((in (open-input-file file)) diff --git a/sexp.c b/sexp.c index ea0adbd9..3fa39a7d 100644 --- a/sexp.c +++ b/sexp.c @@ -392,9 +392,10 @@ sexp sexp_make_flonum(sexp ctx, double f) { sexp sexp_make_string(sexp ctx, sexp len, sexp ch) { sexp_sint_t clen = sexp_unbox_integer(len); - sexp s = sexp_alloc_atomic(ctx, sexp_sizeof(string)+clen+1); - sexp_pointer_tag(s) = SEXP_STRING; + sexp s; if (clen < 0) return sexp_type_exception(ctx, "negative length", len); + s = sexp_alloc_atomic(ctx, sexp_sizeof(string)+clen+1); + sexp_pointer_tag(s) = SEXP_STRING; sexp_string_length(s) = clen; if (sexp_charp(ch)) memset(sexp_string_data(s), sexp_unbox_character(ch), clen); @@ -450,6 +451,7 @@ sexp sexp_string_concatenate (sexp ctx, sexp str_ls) { memcpy(p, sexp_string_data(sexp_car(ls)), len); p += len; } + *p = '\0'; return res; } @@ -702,15 +704,14 @@ sexp sexp_buffered_flush (sexp ctx, sexp p) { else { if (sexp_port_stream(p)) { fwrite(sexp_port_buf(p), 1, sexp_port_offset(p), sexp_port_stream(p)); - sexp_port_offset(p) = 0; fflush(sexp_port_stream(p)); } else if (sexp_port_offset(p) > 0) { sexp_gc_preserve(ctx, tmp, s_tmp); tmp = sexp_c_string(ctx, sexp_port_buf(p), sexp_port_offset(p)); sexp_push(ctx, sexp_port_cookie(p), tmp); - sexp_port_offset(p) = 0; sexp_gc_release(ctx, tmp, s_tmp); } + sexp_port_offset(p) = 0; return SEXP_VOID; } } @@ -735,17 +736,18 @@ sexp sexp_make_output_string_port (sexp ctx) { sexp sexp_get_output_string (sexp ctx, sexp out) { sexp res; + sexp_gc_var(ctx, ls, s_ls); sexp_gc_var(ctx, tmp, s_tmp); + sexp_gc_preserve(ctx, ls, s_ls); sexp_gc_preserve(ctx, tmp, s_tmp); - tmp = ((sexp_port_offset(out) > 0) - ? sexp_cons(ctx, - tmp=sexp_c_string(ctx, - sexp_port_buf(out), - sexp_port_offset(out)), - sexp_port_cookie(out)) - : sexp_port_cookie(out)); - res = sexp_string_concatenate(ctx, tmp); - sexp_gc_release(ctx, tmp, s_tmp); + if (sexp_port_offset(out) > 0) { + tmp = sexp_c_string(ctx, sexp_port_buf(out), sexp_port_offset(out)); + ls = sexp_cons(ctx, tmp, sexp_port_cookie(out)); + } else { + ls = sexp_port_cookie(out); + } + res = sexp_string_concatenate(ctx, ls); + sexp_gc_release(ctx, ls, s_ls); return res; } From 69ab0d02d980c919c6aac609d2039c7110eeea30 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 28 Jun 2009 02:05:13 +0900 Subject: [PATCH 145/154] using names from type specs for unreadable objects in sexp_write --- include/chibi/sexp.h | 1 + sexp.c | 94 +++++--------------------------------------- 2 files changed, 10 insertions(+), 85 deletions(-) diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 869283c1..9f8005cf 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -85,6 +85,7 @@ enum sexp_types { SEXP_LIT, SEXP_STACK, SEXP_CONTEXT, + SEXP_NUM_TYPES, }; typedef unsigned long sexp_uint_t; diff --git a/sexp.c b/sexp.c index 3fa39a7d..3321630c 100644 --- a/sexp.c +++ b/sexp.c @@ -824,91 +824,6 @@ void sexp_write (sexp ctx, sexp obj, sexp out) { sexp_write(ctx, sexp_bytecode_name(sexp_procedure_code(obj)), out); sexp_write_string(ctx, ">", out); break; - case SEXP_IPORT: - sexp_write_string(ctx, "#", out); break; - case SEXP_OPORT: - sexp_write_string(ctx, "#", out); break; - case SEXP_CORE: - sexp_write_string(ctx, "#", out); break; - case SEXP_OPCODE: - sexp_write_string(ctx, "#", out); break; - case SEXP_BYTECODE: - sexp_write_string(ctx, "#", out); break; - case SEXP_ENV: - sexp_write_string(ctx, "#", out); break; -/* sexp_printf(out, "# 5) { */ -/* sexp_write_char(' ', out); */ -/* sexp_write(sexp_caar(x), out); */ -/* sexp_write_string(": ", out); */ -/* if ((! sexp_cdar(x)) || sexp_pointerp(sexp_cdar(x))) */ -/* sexp_printf(out, "%p", sexp_cdar(x)); */ -/* else */ -/* sexp_write(sexp_cdar(x), out); */ -/* sexp_write_string(" ...", out); */ -/* } else for ( ; x && sexp_pairp(x); x=sexp_cdr(x)) { */ -/* sexp_write_char(' ', out); */ -/* sexp_write(sexp_caar(x), out); */ -/* sexp_write_string(": ", out); */ -/* if ((! sexp_cdar(x)) || sexp_pointerp(sexp_cdar(x))) */ -/* sexp_printf(out, "%p", sexp_cdar(x)); */ -/* else */ -/* sexp_write(sexp_cdar(x), out); */ -/* } */ -/* sexp_write_char('>', out); */ - break; - case SEXP_EXCEPTION: - sexp_write_string(ctx, "#", out); break; - case SEXP_MACRO: - sexp_write_string(ctx, "#", out); break; -#if USE_DEBUG - case SEXP_LAMBDA: - sexp_write_string(ctx, "#', out); */ - break; - case SEXP_SEQ: - sexp_write_string(ctx, "#', out); - break; - case SEXP_CND: - sexp_write_string(ctx, "#', out); - break; - case SEXP_REF: - sexp_write_string(ctx, "#", out); -/* sexp_write_string("#", sexp_ref_loc(obj)); */ - break; - case SEXP_SET: - sexp_write_string(ctx, "#", out); - break; - case SEXP_SYNCLO: - sexp_write_string(ctx, "#", out); - break; -#endif - case SEXP_TYPE: - sexp_write_string(ctx, "#", out); - break; case SEXP_STRING: sexp_write_char(ctx, '"', out); i = sexp_string_length(obj); @@ -934,6 +849,15 @@ void sexp_write (sexp ctx, sexp obj, sexp out) { sexp_write_char(ctx, str[0], out); } break; + default: + i = sexp_pointer_tag(obj); + sexp_write_string(ctx, "#<", out); + sexp_write_string(ctx, + (i < SEXP_NUM_TYPES) + ? sexp_type_name(&(sexp_type_specs[i])) : "invalid", + out); + sexp_write_char(ctx, '>', out); + break; } } else if (sexp_integerp(obj)) { sprintf(numbuf, "%ld", sexp_unbox_integer(obj)); From e40fdb3b73c730c18c778267a6a66b6306eb9946 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 28 Jun 2009 02:31:11 +0900 Subject: [PATCH 146/154] using a separate sexp_free_list type, so we don't need the overhead of the sexp tag and should thus fit in any aligned block on 64bit architectures. this also removes a lot of ugly casts, making the code more readable. --- gc.c | 95 +++++++++++++++++++++++++++++------------------------------- 1 file changed, 46 insertions(+), 49 deletions(-) diff --git a/gc.c b/gc.c index caee6213..8f9f718a 100644 --- a/gc.c +++ b/gc.c @@ -11,11 +11,16 @@ #define sexp_heap_align(n) sexp_align(n, 4) -typedef struct sexp_heap *sexp_heap; +typedef struct sexp_free_list *sexp_free_list; +struct sexp_free_list { + sexp_uint_t size; + sexp_free_list next; +}; +typedef struct sexp_heap *sexp_heap; struct sexp_heap { sexp_uint_t size; - sexp free_list; + sexp_free_list free_list; sexp_heap next; char *data; }; @@ -84,7 +89,8 @@ int stack_references_pointer_p (sexp ctx, sexp x) { sexp sexp_sweep (sexp ctx, size_t *sum_freed_ptr) { size_t freed, max_freed=0, sum_freed=0, size; sexp_heap h = heap; - sexp p, q, r; + sexp p; + sexp_free_list q, r, s; char *end; /* scan over the whole heap */ for ( ; h; h=h->next) { @@ -93,41 +99,41 @@ sexp sexp_sweep (sexp ctx, size_t *sum_freed_ptr) { end = (char*)h->data + h->size; while (((char*)p) < end) { /* find the preceding and succeeding free list pointers */ - for (r=sexp_cdr(q); r && sexp_pairp(r) && (rnext; r && ((char*)r<(char*)p); q=r, r=r->next) ; - if (r == p) { - p = (sexp) (((char*)p) + (sexp_uint_t)sexp_car(p)); + if ((char*)r == (char*)p) { + p = (sexp) (((char*)p) + r->size); continue; } size = sexp_heap_align(sexp_allocated_bytes(p)); if ((! sexp_gc_mark(p)) && (! stack_references_pointer_p(ctx, p))) { sum_freed += size; - if (((((char*)q)+(sexp_uint_t)sexp_car(q)) == (char*)p) - && (q != h->free_list)) { + if (((((char*)q) + q->size) == (char*)p) && (q != h->free_list)) { /* merge q with p */ - if (r && sexp_pairp(r) && ((((char*)p)+size) == (char*)r)) { + if (r && ((((char*)p)+size) == (char*)r)) { /* ... and with r */ - sexp_cdr(q) = sexp_cdr(r); - freed = (sexp_uint_t)sexp_car(q) + size + (sexp_uint_t)sexp_car(r); - p = (sexp) (((char*)p)+size+(sexp_uint_t)sexp_car(r)); + q->next = r->next; + freed = q->size + size + r->size; + p = (sexp) (((char*)p) + size + r->size); } else { - freed = (sexp_uint_t)sexp_car(q) + size; + freed = q->size + size; p = (sexp) (((char*)p)+size); } - sexp_car(q) = (sexp)freed; + q->size = freed; } else { - if (r && sexp_pairp(r) && ((((char*)p)+size) == (char*)r)) { - sexp_car(p) = (sexp)(size+(sexp_uint_t)sexp_car(r)); - sexp_cdr(p) = sexp_cdr(r); - sexp_cdr(q) = p; - freed = size + (sexp_uint_t)sexp_car(r); + s = (sexp_free_list)p; + if (r && ((((char*)p)+size) == (char*)r)) { + /* merge p with r */ + s->size = size + r->size; + s->next = r->next; + q->next = s; + freed = size + r->size; } else { - sexp_car(p) = (sexp)size; - sexp_cdr(p) = r; - sexp_cdr(q) = p; + s->size = size; + s->next = r; + q->next = s; freed = size; } - sexp_pointer_tag(p) = SEXP_PAIR; p = (sexp) (((char*)p)+freed); } if (freed > max_freed) @@ -155,21 +161,19 @@ sexp sexp_gc (sexp ctx, size_t *sum_freed) { } sexp_heap sexp_make_heap (size_t size) { - sexp free, next; + sexp_free_list free, next; sexp_heap h = (sexp_heap) malloc(sizeof(struct sexp_heap) + size); if (! h) errx(70, "out of memory allocating %zu byte heap, aborting\n", size); h->size = size; h->data = (char*) sexp_heap_align((sexp_uint_t)&(h->data)); - free = h->free_list = (sexp) h->data; + free = h->free_list = (sexp_free_list) h->data; h->next = NULL; - next = (sexp) ((char*)free + sexp_heap_align(sexp_sizeof(pair))); - sexp_pointer_tag(free) = SEXP_PAIR; - sexp_car(free) = 0; /* actually sexp_sizeof(pair) */ - sexp_cdr(free) = next; - sexp_pointer_tag(next) = SEXP_PAIR; - sexp_car(next) = (sexp) (size - sexp_heap_align(sexp_sizeof(pair))); - sexp_cdr(next) = SEXP_NULL; + next = (sexp_free_list) ((char*)free + sexp_heap_align(sexp_sizeof(pair))); + free->size = 0; /* actually sexp_sizeof(pair) */ + free->next = next; + next->size = size - sexp_heap_align(sexp_sizeof(pair)); + next->next = NULL; return h; } @@ -183,29 +187,22 @@ int sexp_grow_heap (sexp ctx, size_t size) { } void* sexp_try_alloc (sexp ctx, size_t size) { - sexp ls1, ls2, ls3; + sexp_free_list ls1, ls2, ls3; sexp_heap h; - for (h=heap; h; h=h->next) { - ls1 = h->free_list; - ls2 = sexp_cdr(ls1); - while (sexp_pairp(ls2)) { - if ((sexp_uint_t)sexp_car(ls2) >= size) { - if ((sexp_uint_t)sexp_car(ls2) >= (size + SEXP_MINIMUM_OBJECT_SIZE)) { - ls3 = (sexp) (((char*)ls2)+size); /* the free tail after ls2 */ - sexp_pointer_tag(ls3) = SEXP_PAIR; - sexp_car(ls3) = (sexp) (((sexp_uint_t)sexp_car(ls2)) - size); - sexp_cdr(ls3) = sexp_cdr(ls2); - sexp_cdr(ls1) = ls3; + for (h=heap; h; h=h->next) + for (ls1=h->free_list, ls2=ls1->next; ls2; ls1=ls2, ls2=ls2->next) + if (ls2->size >= size) { + if (ls2->size >= (size + SEXP_MINIMUM_OBJECT_SIZE)) { + ls3 = (sexp_free_list) (((char*)ls2)+size); /* the tail after ls2 */ + ls3->size = ls2->size - size; + ls3->next = ls2->next; + ls1->next = ls3; } else { /* take the whole chunk */ - sexp_cdr(ls1) = sexp_cdr(ls2); + ls1->next = ls2->next; } memset((void*)ls2, 0, size); return ls2; } - ls1 = ls2; - ls2 = sexp_cdr(ls2); - } - } return NULL; } From cca8727354aa074128768b21b7d85212f0fb50d8 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 28 Jun 2009 13:10:34 +0900 Subject: [PATCH 147/154] fixing hex char and number syntax, adding support for n/d numbers as floats --- Makefile | 2 +- sexp.c | 35 +++++++++++++++++++++++++---------- 2 files changed, 26 insertions(+), 11 deletions(-) diff --git a/Makefile b/Makefile index edf7867a..84d97ed4 100644 --- a/Makefile +++ b/Makefile @@ -46,7 +46,7 @@ XCPPFLAGS := $(CPPFLAGS) -Iinclude endif XLDFLAGS := $(LDFLAGS) $(GCLDFLAGS) -lm -XCFLAGS := -Wall -O2 -g $(CFLAGS) +XCFLAGS := -Wall -g $(CFLAGS) INCLUDES = include/chibi/sexp.h include/chibi/config.h include/chibi/install.h diff --git a/sexp.c b/sexp.c index 3321630c..b651dc15 100644 --- a/sexp.c +++ b/sexp.c @@ -42,6 +42,10 @@ static int digit_value (c) { return (((c)<='9') ? ((c) - '0') : ((toupper(c) - 'A') + 10)); } +static int hex_digit (n) { + return ((n<=9) ? ('0' + n) : ('A' + n - 10)); +} + static int is_separator(int c) { return 0>4), out); + sexp_write_char(ctx, hex_digit(sexp_unbox_character(obj)&0xF), out); } } else if (sexp_symbolp(obj)) { @@ -915,7 +921,7 @@ void sexp_write (sexp ctx, sexp obj, sexp out) { case (sexp_uint_t) SEXP_VOID: sexp_write_string(ctx, "#", out); break; default: - sexp_write_string(ctx, "#", out); + sexp_write_string(ctx, "#", out); } } } @@ -1005,7 +1011,7 @@ sexp sexp_read_float_tail(sexp ctx, sexp in, sexp_sint_t whole) { } sexp sexp_read_number(sexp ctx, sexp in, int base) { - sexp f; + sexp f, den; sexp_sint_t res = 0, negativep = 0, c; c = sexp_read_char(ctx, in); @@ -1017,6 +1023,7 @@ sexp sexp_read_number(sexp ctx, sexp in, int base) { if (base == 16) for (c=sexp_read_char(ctx, in); isxdigit(c); c=sexp_read_char(ctx, in)) res = res * base + digit_value(c); + else for (c=sexp_read_char(ctx, in); isdigit(c); c=sexp_read_char(ctx, in)) res = res * base + digit_value(c); @@ -1039,11 +1046,18 @@ sexp sexp_read_number(sexp ctx, sexp in, int base) { #endif return f; } + } else if (c=='/') { + den = sexp_read_number(ctx, in, base); + if (! sexp_integerp(den)) + return (sexp_exceptionp(den) + ? den : sexp_read_error(ctx, "invalid rational syntax", den, in)); + return sexp_make_flonum(ctx, (double)(negativep ? -res : res) + / (double)sexp_unbox_integer(den)); } else { - sexp_push_char(ctx, c, in); if ((c!=EOF) && ! is_separator(c)) return sexp_read_error(ctx, "invalid numeric syntax", - sexp_list1(ctx, sexp_make_character(c)), in); + sexp_make_character(c), in); + sexp_push_char(ctx, c, in); } return sexp_make_integer(negativep ? -res : res); @@ -1190,8 +1204,9 @@ sexp sexp_read_raw (sexp ctx, sexp in) { if (sexp_string_length(res) == 1) { res = sexp_make_character(c1); } else if ((c1 == 'x' || c1 == 'X') && - isxdigit(str[0]) && isxdigit(str[1]) && str[2] == '\0') { - res = sexp_make_character(16 * digit_value(c1) + digit_value(str[1])); + isxdigit(str[1]) && isxdigit(str[2]) && str[3] == '\0') { + res = sexp_make_character(16 * digit_value(str[1]) + + digit_value(str[2])); } else { if (strcasecmp(str, "space") == 0) res = sexp_make_character(' '); From ab2cbe12f7daa0ebb1701f763a3169ea6b52eb72 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 28 Jun 2009 13:19:12 +0900 Subject: [PATCH 148/154] gc preserving read errors --- sexp.c | 19 ++++++++----------- 1 file changed, 8 insertions(+), 11 deletions(-) diff --git a/sexp.c b/sexp.c index b651dc15..fb86efa3 100644 --- a/sexp.c +++ b/sexp.c @@ -226,7 +226,8 @@ static sexp sexp_read_error (sexp ctx, char *msg, sexp irritants, sexp port) { sexp_gc_preserve(ctx, irr, s_irr); name = (sexp_port_name(port) ? sexp_port_name(port) : SEXP_FALSE); str = sexp_c_string(ctx, msg, -1); - irr = (sexp_pairp(irritants) ? irritants : sexp_list1(ctx, irritants)); + irr = ((sexp_pairp(irritants) || sexp_nullp(irritants)) + ? irritants : sexp_list1(ctx, irritants)); res = sexp_make_exception(ctx, the_read_error_symbol, str, irr, SEXP_FALSE, name, sexp_make_integer(sexp_port_line(port))); @@ -1006,7 +1007,7 @@ sexp sexp_read_float_tail(sexp ctx, sexp in, sexp_sint_t whole) { : sexp_flonump(exponent) ? sexp_flonum_value(exponent) : 0.0); } else if ((c!=EOF) && ! is_separator(c)) return sexp_read_error(ctx, "invalid numeric syntax", - sexp_list1(ctx, sexp_make_character(c)), in); + sexp_make_character(c), in); return sexp_make_flonum(ctx, (whole + res) * pow(10, e)); } @@ -1177,11 +1178,8 @@ sexp sexp_read_raw (sexp ctx, sexp in) { res = (c1 == 't' ? SEXP_TRUE : SEXP_FALSE); sexp_push_char(ctx, c2, in); } else { - res = sexp_read_error(ctx, "invalid syntax #%c%c", - sexp_list2(ctx, - sexp_make_character(c1), - sexp_make_character(c2)), - in); + tmp = sexp_list2(ctx, sexp_make_character(c1), sexp_make_character(c2)); + res = sexp_read_error(ctx, "invalid syntax #%c%c", tmp, in); } break; /* case '0': case '1': case '2': case '3': case '4': */ @@ -1217,9 +1215,8 @@ sexp sexp_read_raw (sexp ctx, sexp in) { else if (strcasecmp(str, "tab") == 0) res = sexp_make_character('\t'); else { - res = sexp_read_error(ctx, "unknown character name", - sexp_list1(ctx, sexp_c_string(ctx, str, -1)), - in); + tmp = sexp_c_string(ctx, str, -1); + res = sexp_read_error(ctx, "unknown character name", tmp, in); } } } @@ -1239,7 +1236,7 @@ sexp sexp_read_raw (sexp ctx, sexp in) { break; default: res = sexp_read_error(ctx, "invalid # syntax", - sexp_list1(ctx, sexp_make_character(c1)), in); + sexp_make_character(c1), in); } break; case '.': From f1e7c3a2db218f5c41b43335aad9981f57bb1bab Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 28 Jun 2009 14:52:52 +0900 Subject: [PATCH 149/154] reporting source file and line number for compile-time errors --- eval.c | 8 ++++++-- include/chibi/sexp.h | 13 +++++++----- main.c | 17 ++++++++++------ sexp.c | 47 ++++++++++++++++++++++++++------------------ 4 files changed, 53 insertions(+), 32 deletions(-) diff --git a/eval.c b/eval.c index 74838c26..871feb9d 100644 --- a/eval.c +++ b/eval.c @@ -368,7 +368,8 @@ static sexp sexp_compile_error(sexp ctx, char *message, sexp obj) { irritants = sexp_list1(ctx, obj); msg = sexp_c_string(ctx, message, -1); exn = sexp_make_exception(ctx, the_compile_error_symbol, msg, irritants, - SEXP_FALSE, SEXP_FALSE, SEXP_FALSE); + SEXP_FALSE, (sexp_pairp(obj) ? + sexp_pair_source(obj) : SEXP_FALSE)); sexp_gc_release(ctx, irritants, s_irr); return exn; } @@ -558,7 +559,9 @@ static sexp analyze_define (sexp ctx, sexp x) { res = sexp_compile_error(ctx, "bad define syntax", x); } else { name = (sexp_pairp(sexp_cadr(x)) ? sexp_caadr(x) : sexp_cadr(x)); - if (sexp_env_lambda(env) && sexp_lambdap(sexp_env_lambda(env))) { + if (! sexp_idp(name)) { + res = sexp_compile_error(ctx, "can't define a non-symbol", x); + } else if (sexp_env_lambda(env) && sexp_lambdap(sexp_env_lambda(env))) { tmp = sexp_cons(ctx, name, sexp_context_lambda(ctx)); sexp_push(ctx, sexp_env_bindings(env), tmp); sexp_push(ctx, sexp_lambda_sv(sexp_env_lambda(env)), name); @@ -1894,6 +1897,7 @@ sexp sexp_load (sexp ctx, sexp source, sexp env) { sexp_print_exception(ctx, in, out); res = in; } else { + sexp_port_sourcep(in) = 1; while ((x=sexp_read(ctx, in)) != (sexp) SEXP_EOF) { res = sexp_eval(ctx2, x); if (sexp_exceptionp(res)) diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 9f8005cf..8ab96d98 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -114,6 +114,7 @@ struct sexp_struct { } type; struct { sexp car, cdr; + sexp source; } pair; struct { sexp_uint_t length; @@ -129,12 +130,12 @@ struct sexp_struct { struct { FILE *stream; char *buf; - sexp_uint_t offset, line, size, openp; + sexp_uint_t offset, line, size, openp, sourcep; sexp name; sexp cookie; } port; struct { - sexp kind, message, irritants, procedure, file, line; + sexp kind, message, irritants, procedure, source; } exception; struct { char sign; @@ -374,6 +375,7 @@ sexp sexp_make_flonum(sexp ctx, double f); #define sexp_port_name(p) ((p)->value.port.name) #define sexp_port_line(p) ((p)->value.port.line) #define sexp_port_openp(p) ((p)->value.port.openp) +#define sexp_port_sourcep(p) ((p)->value.port.sourcep) #define sexp_port_cookie(p) ((p)->value.port.cookie) #define sexp_port_buf(p) ((p)->value.port.buf) #define sexp_port_size(p) ((p)->value.port.size) @@ -383,8 +385,7 @@ sexp sexp_make_flonum(sexp ctx, double f); #define sexp_exception_message(p) ((p)->value.exception.message) #define sexp_exception_irritants(p) ((p)->value.exception.irritants) #define sexp_exception_procedure(p) ((p)->value.exception.procedure) -#define sexp_exception_file(p) ((p)->value.exception.file) -#define sexp_exception_line(p) ((p)->value.exception.line) +#define sexp_exception_source(p) ((p)->value.exception.source) #define sexp_bytecode_length(x) ((x)->value.bytecode.length) #define sexp_bytecode_name(x) ((x)->value.bytecode.name) @@ -498,6 +499,8 @@ sexp sexp_make_flonum(sexp ctx, double f); #define sexp_push(ctx, ls, x) ((ls) = sexp_cons((ctx), (x), (ls))) #define sexp_insert(ctx, ls, x) ((sexp_memq(NULL, (x), (ls)) != SEXP_FALSE) ? (ls) : sexp_push((ctx), (ls), (x))) +#define sexp_pair_source(x) ((x)->value.pair.source) + #define sexp_car(x) ((x)->value.pair.car) #define sexp_cdr(x) ((x)->value.pair.cdr) @@ -576,7 +579,7 @@ sexp sexp_make_output_port(sexp ctx, FILE* out, sexp name); sexp sexp_make_input_string_port(sexp ctx, sexp str); sexp sexp_make_output_string_port(sexp ctx); sexp sexp_get_output_string(sexp ctx, sexp port); -sexp sexp_make_exception(sexp ctx, sexp kind, sexp message, sexp irritants, sexp procedure, sexp file, sexp line); +sexp sexp_make_exception(sexp ctx, sexp kind, sexp message, sexp irritants, sexp procedure, sexp source); sexp sexp_user_exception (sexp ctx, sexp self, char *message, sexp obj); sexp sexp_type_exception (sexp ctx, char *message, sexp obj); sexp sexp_range_exception (sexp ctx, sexp obj, sexp start, sexp end); diff --git a/main.c b/main.c index 7854beba..1d1f88b9 100644 --- a/main.c +++ b/main.c @@ -52,6 +52,7 @@ void repl (sexp ctx) { in = sexp_eval_string(ctx, "(current-input-port)"); out = sexp_eval_string(ctx, "(current-output-port)"); err = sexp_eval_string(ctx, "(current-error-port)"); + sexp_port_sourcep(in) = 1; while (1) { sexp_write_string(ctx, "> ", out); sexp_flush(ctx, out); @@ -98,6 +99,8 @@ void run_main (int argc, char **argv) { res = sexp_eval(ctx, res); if (sexp_exceptionp(res)) { sexp_print_exception(ctx, res, out); + quit = 1; + break; } else if (argv[i][1] == 'p') { sexp_write(ctx, res, out); sexp_write_char(ctx, '\n', out); @@ -123,12 +126,14 @@ void run_main (int argc, char **argv) { if (! quit) { if (! init_loaded) - sexp_load(ctx, str=find_module_file(ctx, sexp_init_file), env); - if (i < argc) - for ( ; i < argc; i++) - sexp_load(ctx, str=sexp_c_string(ctx, argv[i], -1), env); - else - repl(ctx); + res = sexp_load(ctx, str=find_module_file(ctx, sexp_init_file), env); + if (! sexp_exceptionp(res)) { + if (i < argc) + for ( ; i < argc; i++) + sexp_load(ctx, str=sexp_c_string(ctx, argv[i], -1), env); + else + repl(ctx); + } } sexp_gc_release(ctx, str, s_str); diff --git a/sexp.c b/sexp.c index fb86efa3..9b909936 100644 --- a/sexp.c +++ b/sexp.c @@ -69,7 +69,7 @@ static struct sexp_struct sexp_type_specs[] = { _DEF_TYPE(SEXP_FIXNUM, 0, 0, 0, 0, 0, 0, 0, "fixnum"), _DEF_TYPE(SEXP_CHAR, 0, 0, 0, 0, 0, 0, 0, "char"), _DEF_TYPE(SEXP_BOOLEAN, 0, 0, 0, 0, 0, 0, 0, "boolean"), - _DEF_TYPE(SEXP_PAIR, sexp_offsetof(pair, car), 2, 0, 0, sexp_sizeof(pair), 0, 0, "pair"), + _DEF_TYPE(SEXP_PAIR, sexp_offsetof(pair, car), 3, 0, 0, sexp_sizeof(pair), 0, 0, "pair"), _DEF_TYPE(SEXP_SYMBOL, sexp_offsetof(symbol, string), 1, 0, 0, sexp_sizeof(symbol), 0, 0, "symbol"), _DEF_TYPE(SEXP_STRING, 0, 0, 0, 0, sexp_sizeof(string)+1, sexp_offsetof(string, length), 1, "string"), _DEF_TYPE(SEXP_VECTOR, sexp_offsetof(vector, data), 0, sexp_offsetof(vector, length), 1, sexp_sizeof(vector), sexp_offsetof(vector, length), 4, "vector"), @@ -106,14 +106,13 @@ static struct sexp_struct sexp_type_specs[] = { /***************************** exceptions *****************************/ sexp sexp_make_exception (sexp ctx, sexp kind, sexp message, sexp irritants, - sexp procedure, sexp file, sexp line) { + sexp procedure, sexp source) { sexp exn = sexp_alloc_type(ctx, exception, SEXP_EXCEPTION); sexp_exception_kind(exn) = kind; sexp_exception_message(exn) = message; sexp_exception_irritants(exn) = irritants; sexp_exception_procedure(exn) = procedure; - sexp_exception_file(exn) = file; - sexp_exception_line(exn) = line; + sexp_exception_source(exn) = source; return exn; } @@ -129,7 +128,7 @@ sexp sexp_user_exception (sexp ctx, sexp self, char *message, sexp irritants) { str = sexp_c_string(ctx, message, -1), ((sexp_pairp(irritants) || sexp_nullp(irritants)) ? irritants : (irr = sexp_list1(ctx, irritants))), - self, SEXP_FALSE, SEXP_FALSE); + self, SEXP_FALSE); sexp_gc_release(ctx, sym, s_sym); return res; } @@ -145,7 +144,7 @@ sexp sexp_type_exception (sexp ctx, char *message, sexp obj) { res = sexp_make_exception(ctx, sym = sexp_intern(ctx, "type"), str = sexp_c_string(ctx, message, -1), irr = sexp_list1(ctx, obj), - SEXP_FALSE, SEXP_FALSE, SEXP_FALSE); + SEXP_FALSE, SEXP_FALSE); sexp_gc_release(ctx, sym, s_sym); return res; } @@ -159,7 +158,7 @@ sexp sexp_range_exception (sexp ctx, sexp obj, sexp start, sexp end) { res = sexp_list2(ctx, start, end); res = sexp_cons(ctx, obj, res); res = sexp_make_exception(ctx, sexp_intern(ctx, "range"), msg, res, - SEXP_FALSE, SEXP_FALSE, SEXP_FALSE); + SEXP_FALSE, SEXP_FALSE); sexp_gc_release(ctx, res, s_res); return res; } @@ -176,14 +175,16 @@ sexp sexp_print_exception (sexp ctx, sexp exn, sexp out) { sexp_write(ctx, ls, out); } } - if (sexp_integerp(sexp_exception_line(exn)) - && (sexp_exception_line(exn) > sexp_make_integer(0))) { - sexp_write_string(ctx, " on line ", out); - sexp_write(ctx, sexp_exception_line(exn), out); - } - if (sexp_stringp(sexp_exception_file(exn))) { - sexp_write_string(ctx, " of file ", out); - sexp_write_string(ctx, sexp_string_data(sexp_exception_file(exn)), out); + if (sexp_pairp(sexp_exception_source(exn))) { + if (sexp_integerp(sexp_cdr(sexp_exception_source(exn))) + && (sexp_cdr(sexp_exception_source(exn)) >= sexp_make_integer(0))) { + sexp_write_string(ctx, " on line ", out); + sexp_write(ctx, sexp_cdr(sexp_exception_source(exn)), out); + } + if (sexp_stringp(sexp_car(sexp_exception_source(exn)))) { + sexp_write_string(ctx, " of file ", out); + sexp_write_string(ctx, sexp_string_data(sexp_car(sexp_exception_source(exn))), out); + } } sexp_write_string(ctx, ": ", out); sexp_write_string(ctx, sexp_string_data(sexp_exception_message(exn)), out); @@ -221,16 +222,18 @@ static sexp sexp_read_error (sexp ctx, char *msg, sexp irritants, sexp port) { sexp_gc_var(ctx, name, s_name); sexp_gc_var(ctx, str, s_str); sexp_gc_var(ctx, irr, s_irr); + sexp_gc_var(ctx, src, s_src); sexp_gc_preserve(ctx, name, s_name); sexp_gc_preserve(ctx, str, s_str); sexp_gc_preserve(ctx, irr, s_irr); + sexp_gc_preserve(ctx, src, s_src); name = (sexp_port_name(port) ? sexp_port_name(port) : SEXP_FALSE); + name = sexp_cons(ctx, name, sexp_make_integer(sexp_port_line(port))); str = sexp_c_string(ctx, msg, -1); irr = ((sexp_pairp(irritants) || sexp_nullp(irritants)) ? irritants : sexp_list1(ctx, irritants)); res = sexp_make_exception(ctx, the_read_error_symbol, - str, irr, SEXP_FALSE, name, - sexp_make_integer(sexp_port_line(port))); + str, irr, SEXP_FALSE, name); sexp_gc_release(ctx, name, s_name); return res; } @@ -241,6 +244,7 @@ sexp sexp_cons (sexp ctx, sexp head, sexp tail) { sexp pair = sexp_alloc_type(ctx, pair, SEXP_PAIR); sexp_car(pair) = head; sexp_cdr(pair) = tail; + sexp_pair_source(pair) = SEXP_FALSE; return pair; } @@ -765,9 +769,10 @@ sexp sexp_make_input_port (sexp ctx, FILE* in, sexp name) { sexp p = sexp_alloc_type(ctx, port, SEXP_IPORT); sexp_port_stream(p) = in; sexp_port_name(p) = name; - sexp_port_line(p) = 0; + sexp_port_line(p) = 1; sexp_port_buf(p) = NULL; sexp_port_openp(p) = 1; + sexp_port_sourcep(p) = 1; sexp_port_cookie(p) = SEXP_VOID; return p; } @@ -1066,7 +1071,7 @@ sexp sexp_read_number(sexp ctx, sexp in, int base) { sexp sexp_read_raw (sexp ctx, sexp in) { char *str; - int c1, c2; + int c1, c2, line; sexp tmp2; sexp_gc_var(ctx, res, s_res); sexp_gc_var(ctx, tmp, s_tmp); @@ -1113,6 +1118,7 @@ sexp sexp_read_raw (sexp ctx, sexp in) { res = sexp_read_string(ctx, in); break; case '(': + line = (sexp_port_sourcep(in) ? sexp_port_line(in) : -1); res = SEXP_NULL; tmp = sexp_read_raw(ctx, in); while ((tmp != SEXP_EOF) && (tmp != SEXP_CLOSE) && (tmp != SEXP_RAWDOT)) { @@ -1150,6 +1156,9 @@ sexp sexp_read_raw (sexp ctx, sexp in) { res = sexp_read_error(ctx, "missing trailing ')'", SEXP_NULL, in); } } + if ((line >= 0) && sexp_pairp(res)) + sexp_pair_source(res) + = sexp_cons(ctx, sexp_port_name(in), sexp_make_integer(line)); break; case '#': switch (c1=sexp_read_char(ctx, in)) { From 343303f408f643f29200630f8cc0862884c7228e Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 28 Jun 2009 17:46:37 +0900 Subject: [PATCH 150/154] cleaning up plan9 mkfile and providing install target --- .hgignore | 20 + Makefile | 116 ++ README | 52 + VERSION | 1 + debug.c | 75 + eval.c | 2187 ++++++++++++++++++++++++ gc.c | 237 +++ include/chibi/config.h | 120 ++ include/chibi/eval.h | 140 ++ include/chibi/sexp.h | 590 +++++++ init.scm | 713 ++++++++ main.c | 152 ++ mkfile | 36 + opcodes.c | 129 ++ opt/sexp-huff.c | 128 ++ opt/sexp-hufftabs.c | 92 + opt/sexp-unhuff.c | 71 + sexp.c | 1350 +++++++++++++++ tests/basic/test00-fact-3.res | 1 + tests/basic/test00-fact-3.scm | 14 + tests/basic/test01-apply.res | 8 + tests/basic/test01-apply.scm | 18 + tests/basic/test02-closure.res | 6 + tests/basic/test02-closure.scm | 16 + tests/basic/test03-nested-closure.res | 1 + tests/basic/test03-nested-closure.scm | 8 + tests/basic/test04-nested-let.res | 1 + tests/basic/test04-nested-let.scm | 9 + tests/basic/test05-internal-define.res | 1 + tests/basic/test05-internal-define.scm | 8 + tests/basic/test06-letrec.res | 4 + tests/basic/test06-letrec.scm | 15 + tests/basic/test07-mutation.res | 1 + tests/basic/test07-mutation.scm | 9 + tests/basic/test08-callcc.res | 1 + tests/basic/test08-callcc.scm | 34 + tests/basic/test09-hygiene.res | 7 + tests/basic/test09-hygiene.scm | 62 + tests/basic/test10-unhygiene.res | 6 + tests/basic/test10-unhygiene.scm | 49 + tests/r5rs-tests.scm | 377 ++++ 41 files changed, 6865 insertions(+) create mode 100644 .hgignore create mode 100644 Makefile create mode 100644 README create mode 100644 VERSION create mode 100644 debug.c create mode 100644 eval.c create mode 100644 gc.c create mode 100644 include/chibi/config.h create mode 100644 include/chibi/eval.h create mode 100644 include/chibi/sexp.h create mode 100644 init.scm create mode 100644 main.c create mode 100644 mkfile create mode 100644 opcodes.c create mode 100644 opt/sexp-huff.c create mode 100644 opt/sexp-hufftabs.c create mode 100644 opt/sexp-unhuff.c create mode 100644 sexp.c create mode 100644 tests/basic/test00-fact-3.res create mode 100644 tests/basic/test00-fact-3.scm create mode 100644 tests/basic/test01-apply.res create mode 100644 tests/basic/test01-apply.scm create mode 100644 tests/basic/test02-closure.res create mode 100644 tests/basic/test02-closure.scm create mode 100644 tests/basic/test03-nested-closure.res create mode 100644 tests/basic/test03-nested-closure.scm create mode 100644 tests/basic/test04-nested-let.res create mode 100644 tests/basic/test04-nested-let.scm create mode 100644 tests/basic/test05-internal-define.res create mode 100644 tests/basic/test05-internal-define.scm create mode 100644 tests/basic/test06-letrec.res create mode 100644 tests/basic/test06-letrec.scm create mode 100644 tests/basic/test07-mutation.res create mode 100644 tests/basic/test07-mutation.scm create mode 100644 tests/basic/test08-callcc.res create mode 100644 tests/basic/test08-callcc.scm create mode 100644 tests/basic/test09-hygiene.res create mode 100644 tests/basic/test09-hygiene.scm create mode 100644 tests/basic/test10-unhygiene.res create mode 100644 tests/basic/test10-unhygiene.scm create mode 100644 tests/r5rs-tests.scm diff --git a/.hgignore b/.hgignore new file mode 100644 index 00000000..9d217d26 --- /dev/null +++ b/.hgignore @@ -0,0 +1,20 @@ +syntax: glob +*~ +*.i +*.s +*.o +*.so +*.dylib +*.dSYM +*.orig +.hg +junk* +*.tar.gz +*.tar.bz2 +*.log +*.err +*.out +gc +gc6.8 +chibi-scheme +include/chibi/install.h diff --git a/Makefile b/Makefile new file mode 100644 index 00000000..84d97ed4 --- /dev/null +++ b/Makefile @@ -0,0 +1,116 @@ +# -*- makefile-gmake -*- + +.PHONY: all doc dist clean cleaner test install uninstall + +all: chibi-scheme + +CC ?= cc +PREFIX ?= /usr/local +BINDIR ?= $(PREFIX)/bin +LIBDIR ?= $(PREFIX)/lib +INCDIR ?= $(PREFIX)/include/chibi +MODDIR ?= $(PREFIX)/share/chibi + +ifndef PLATFORM +ifeq ($(shell uname),Darwin) +PLATFORM=macosx +else +PLATFORM=unix +endif +endif + +ifeq ($(PLATFORM),macosx) +SO = .dylib +EXE = +CLIBFLAGS = -dynamiclib +STATICFLAGS = -static-libgcc +else +ifeq ($(PLATFORM),mingw) +SO = .dll +EXE = .exe +CLIBFLAGS = -fPIC -shared +else +SO = .so +EXE = +CLIBFLAGS = -fPIC -shared +STATICFLAGS = -static +endif +endif + +ifdef USE_BOEHM +GCLDFLAGS := -lgc +XCPPFLAGS := $(CPPFLAGS) -Iinclude -DUSE_BOEHM=1 +else +GCLDFLAGS := +XCPPFLAGS := $(CPPFLAGS) -Iinclude +endif + +XLDFLAGS := $(LDFLAGS) $(GCLDFLAGS) -lm +XCFLAGS := -Wall -g $(CFLAGS) + +INCLUDES = include/chibi/sexp.h include/chibi/config.h include/chibi/install.h + +include/chibi/install.h: Makefile + echo '#define sexp_module_dir "'$(MODDIR)'"' > $@ + +sexp.o: sexp.c gc.c $(INCLUDES) Makefile + $(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -o $@ $< + +eval.o: eval.c debug.c opcodes.c include/chibi/eval.h $(INCLUDES) Makefile + $(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -o $@ $< + +main.o: main.c $(INCLUDES) Makefile + $(CC) -c $(XCPPFLAGS) $(XCFLAGS) -o $@ $< + +libchibi-scheme$(SO): eval.o sexp.o + $(CC) $(CLIBFLAGS) -o $@ $^ $(XLDFLAGS) + +chibi-scheme$(EXE): main.o libchibi-scheme$(SO) + $(CC) $(XCPPFLAGS) $(XCFLAGS) -o $@ $< -L. -lchibi-scheme + +chibi-scheme-static$(EXE): main.o eval.o sexp.o + $(CC) $(XCFLAGS) $(STATICFLAGS) -o $@ $^ $(XLDFLAGS) + +clean: + rm -f *.o *.i *.s + +cleaner: clean + rm -f chibi-scheme chibi-scheme-static *$(SO) + rm -rf *.dSYM + +test-basic: chibi-scheme + @for f in tests/basic/*.scm; do \ + ./chibi-scheme $$f >$${f%.scm}.out 2>$${f%.scm}.err; \ + if diff -q $${f%.scm}.out $${f%.scm}.res; then \ + echo "[PASS] $${f%.scm}"; \ + else \ + echo "[FAIL] $${f%.scm}"; \ + fi; \ + done + +test: chibi-scheme + ./chibi-scheme tests/r5rs-tests.scm + +install: chibi-scheme + mkdir -p $(BINDIR) + cp chibi-scheme $(BINDIR)/ + mkdir -p $(MODDIR) + cp init.scm $(MODDIR)/ + mkdir -p $(INCDIR) + cp $(INCLUDES) include/chibi/eval.h $(INCDIR)/ + mkdir -p $(LIBDIR) + cp libchibi-scheme$(SO) $(LIBDIR)/ + if type ldconfig >/dev/null 2>/dev/null; then ldconfig; fi + +uninstall: + rm -f $(BINDIR)/chibi-scheme* + rm -f $(LIBDIR)/libchibi-scheme$(SO) + cd $(INCDIR) && rm -f $(INCLUDES) include/chibi/eval.h + rm -f $(MODDIR)/*.scm + +dist: cleaner + rm -f chibi-scheme-`cat VERSION`.tgz + mkdir chibi-scheme-`cat VERSION` + for f in `hg manifest`; do mkdir -p chibi-scheme-`cat VERSION`/`dirname $$f`; ln -s `pwd`/$$f chibi-scheme-`cat VERSION`/$$f; done + tar cphzvf chibi-scheme-`cat VERSION`.tgz chibi-scheme-`cat VERSION` + rm -rf chibi-scheme-`cat VERSION` diff --git a/README b/README new file mode 100644 index 00000000..bfd07571 --- /dev/null +++ b/README @@ -0,0 +1,52 @@ + + Chibi-Scheme + -------------- + + Minimal Scheme Implementation for use as an Extension Language + + http://synthcode.com/wiki/chibi-scheme/ + + +Chibi-Scheme is a very small but mostly complete R5RS Scheme +implementation using a reasonably fast custom VM. Chibi-Scheme tries +as much as possible not to trade its small size by cutting corners, +and provides full continuations, both low and high-level hygienic +macros based on syntactic-closures, string ports and exceptions. +Chibi-Scheme is written in highly portable C and supports multiple +simultaneous VM instances to run. + +To build, just run "make". This will provide a shared library +"libchibi-scheme", as well as a sample "chibi-scheme" command-line +repl. The "chibi-scheme-static" make target builds an equivalent +static executable. + +You can edit the file config.h for a number of settings, mostly +disabling features to make the executable smaller. You can specify +standard options directly as arguments to make, for example + + make CFLAGS=-Os + +to optimize for size, or + + make LDFLAGS=-L/usr/local/lib CPPFLAGS=-I/usr/local/include + +to compile against a library installed in /usr/local. + +By default Chibi uses a custom, precise, non-moving GC. You can link +against the Boehm conservative GC by editing the config file, or +directly from make with: + + make USE_BOEHM=1 + +See the file main.c for an example of using chibi-scheme as a library. +The essential functions to remember are: + + sexp_make_context(NULL, NULL, NULL) + returns a new context + + sexp_eval(context, expr) + evaluates an s-expression + + sexp_eval_string(context, str) + reads an s-expression from str and evaluates it + diff --git a/VERSION b/VERSION new file mode 100644 index 00000000..3b04cfb6 --- /dev/null +++ b/VERSION @@ -0,0 +1 @@ +0.2 diff --git a/debug.c b/debug.c new file mode 100644 index 00000000..d8a51689 --- /dev/null +++ b/debug.c @@ -0,0 +1,75 @@ +/* debug.c -- optional debugging utilities */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +static const char* reverse_opcode_names[] = + {"NOOP", "RAISE", "RESUMECC", "CALLCC", "APPLY1", "TAIL-CALL", "CALL", + "FCALL0", "FCALL1", "FCALL2", "FCALL3", "FCALL4", "FCALL5", "FCALL6", + "EVAL", "JUMP-UNLESS", + "JUMP", "PUSH", "DROP", "GLOBAL-REF", "GLOBAL-KNOWN-REF", "STACK-REF", + "LOCAL-REF", "LOCAL-SET", + "CLOSURE-REF", "VECTOR-REF", "VECTOR-SET", "VECTOR-LENGTH", "STRING-REF", + "STRING-SET", "STRING-LENGTH", "MAKE-PROCEDURE", "MAKE-VECTOR", "AND", + "NULL?", "FIXNUM?", "SYMBOL?", "CHAR?", + "EOF?", "TYPEP", "CAR", "CDR", "SET-CAR", "SET-CDR", "CONS", "ADD", "SUB", + "MUL", "DIV", "QUOTIENT", "REMAINDER", "NEGATIVE", "INVERSE", + "LT", "LE", "EQN", "EQ", + "EXACT->INEXACT", "INEXACT->EXACT", + "CHAR->INTEGER", "INTEGER->CHAR", "CHAR-UPCASE", "CHAR-DOWNCASE", + "DISPLAY", "WRITE", "WRITE-CHAR", + "NEWLINE", "FLUSH-OUTPUT", "READ", "READ-CHAR", "PEEK-CHAR", "RET", "DONE", + }; + +static sexp sexp_disasm (sexp ctx, sexp bc, sexp out) { + unsigned char *ip, opcode; + if (sexp_procedurep(bc)) + bc = sexp_procedure_code(bc); + ip = sexp_bytecode_data(bc); + loop: + opcode = *ip++; + if (opcode*sizeof(char*) < sizeof(reverse_opcode_names)) { + sexp_printf(ctx, out, " %s ", reverse_opcode_names[opcode]); + } else { + sexp_printf(ctx, out, " %d ", opcode); + } + switch (opcode) { + case OP_STACK_REF: + case OP_LOCAL_REF: + case OP_LOCAL_SET: + case OP_CLOSURE_REF: + case OP_JUMP: + case OP_JUMP_UNLESS: + case OP_FCALL0: + case OP_FCALL1: + case OP_FCALL2: + case OP_FCALL3: + case OP_TYPEP: + sexp_printf(ctx, out, "%ld", (sexp_sint_t) ((sexp*)ip)[0]); + ip += sizeof(sexp); + break; + case OP_GLOBAL_REF: + case OP_GLOBAL_KNOWN_REF: + case OP_TAIL_CALL: + case OP_CALL: + case OP_PUSH: + sexp_write(ctx, ((sexp*)ip)[0], out); + ip += sizeof(sexp); + break; + } + sexp_write_char(ctx, '\n', out); + if (ip - sexp_bytecode_data(bc) < sexp_bytecode_length(bc)) + goto loop; + return SEXP_VOID; +} + +#ifdef DEBUG_VM +static void sexp_print_stack (sexp *stack, int top, int fp, sexp out) { + int i; + for (i=0; i sexp_opcode_num_args(op)) + && (! sexp_opcode_variadic_p(op))) { + res = sexp_compile_error(ctx, "too many args for opcode", x); + } else { + res = analyze_app(ctx, sexp_cdr(x)); + if (! sexp_exceptionp(res)) + sexp_push(ctx, res, op); + } + } else { + res = analyze_app(ctx, x); + } + } + } else if (sexp_truep(sexp_listp(ctx, sexp_car(x))) + || (sexp_synclop(sexp_car(x)) + && sexp_truep(sexp_listp(ctx, + sexp_synclo_expr(sexp_car(x)))))) { + res = analyze_app(ctx, x); + } else { + res = sexp_compile_error(ctx, "invalid operand in application", x); + } + } else if (sexp_idp(x)) { + res = analyze_var_ref(ctx, x); + } else if (sexp_synclop(x)) { + ctx = sexp_make_child_context(ctx, sexp_context_lambda(ctx)); + sexp_context_env(ctx) = sexp_synclo_env(x); + sexp_context_fv(ctx) = sexp_append2(ctx, + sexp_synclo_free_vars(x), + sexp_context_fv(ctx)); + x = sexp_synclo_expr(x); + goto loop; + } else { + res = x; + } + sexp_gc_release(ctx, res, s_res); + return res; +} + +static sexp_sint_t sexp_context_make_label (sexp ctx) { + sexp_sint_t label = sexp_context_pos(ctx); + sexp_context_pos(ctx) += sizeof(sexp_uint_t); + return label; +} + +static void sexp_context_patch_label (sexp ctx, sexp_sint_t label) { + sexp bc = sexp_context_bc(ctx); + unsigned char *data = sexp_bytecode_data(bc)+label; + *((sexp_sint_t*)data) = sexp_context_pos(ctx)-label; +} + +static sexp finalize_bytecode (sexp ctx) { + emit(ctx, OP_RET); + shrink_bcode(ctx, sexp_context_pos(ctx)); + return sexp_context_bc(ctx); +} + +static void generate_lit (sexp ctx, sexp value) { + emit_push(ctx, value); +} + +static void generate_seq (sexp ctx, sexp app) { + sexp head=app, tail=sexp_cdr(app); + sexp_uint_t tailp = sexp_context_tailp(ctx); + sexp_context_tailp(ctx) = 0; + for ( ; sexp_pairp(tail); head=tail, tail=sexp_cdr(tail)) + if (sexp_pointerp(sexp_car(head)) && (! sexp_litp(sexp_car(head)))) { + generate(ctx, sexp_car(head)); + emit(ctx, OP_DROP); + sexp_context_depth(ctx)--; + } + sexp_context_tailp(ctx) = tailp; + generate(ctx, sexp_car(head)); +} + +static void generate_cnd (sexp ctx, sexp cnd) { + sexp_sint_t label1, label2, tailp=sexp_context_tailp(ctx); + sexp_context_tailp(ctx) = 0; + generate(ctx, sexp_cnd_test(cnd)); + sexp_context_tailp(ctx) = tailp; + emit(ctx, OP_JUMP_UNLESS); + sexp_context_depth(ctx)--; + label1 = sexp_context_make_label(ctx); + generate(ctx, sexp_cnd_pass(cnd)); + emit(ctx, OP_JUMP); + sexp_context_depth(ctx)--; + label2 = sexp_context_make_label(ctx); + sexp_context_patch_label(ctx, label1); + generate(ctx, sexp_cnd_fail(cnd)); + sexp_context_patch_label(ctx, label2); +} + +static void generate_non_global_ref (sexp ctx, sexp name, sexp cell, + sexp lambda, sexp fv, int unboxp) { + sexp_uint_t i; + sexp loc = sexp_cdr(cell); + if (loc == lambda && sexp_lambdap(lambda)) { + /* local ref */ + emit(ctx, OP_LOCAL_REF); + emit_word(ctx, sexp_param_index(lambda, name)); + } else { + /* closure ref */ + for (i=0; sexp_pairp(fv); fv=sexp_cdr(fv), i++) + if ((name == sexp_ref_name(sexp_car(fv))) + && (loc == sexp_ref_loc(sexp_car(fv)))) + break; + emit(ctx, OP_CLOSURE_REF); + emit_word(ctx, i); + } + if (unboxp && (sexp_memq(ctx, name, sexp_lambda_sv(loc)) != SEXP_FALSE)) + emit(ctx, OP_CDR); + sexp_context_depth(ctx)++; +} + +static void generate_ref (sexp ctx, sexp ref, int unboxp) { + sexp lam; + if (! sexp_lambdap(sexp_ref_loc(ref))) { + /* global ref */ + if (unboxp) { + emit(ctx, + (sexp_cdr(sexp_ref_cell(ref)) == SEXP_UNDEF) + ? OP_GLOBAL_REF : OP_GLOBAL_KNOWN_REF); + emit_word(ctx, (sexp_uint_t)sexp_ref_cell(ref)); + } else + emit_push(ctx, sexp_ref_cell(ref)); + } else { + lam = sexp_context_lambda(ctx); + generate_non_global_ref(ctx, sexp_ref_name(ref), sexp_ref_cell(ref), + lam, sexp_lambda_fv(lam), unboxp); + } +} + +static void generate_set (sexp ctx, sexp set) { + sexp ref = sexp_set_var(set), lambda; + /* compile the value */ + sexp_context_tailp(ctx) = 0; + if (sexp_lambdap(sexp_set_value(set))) + sexp_lambda_name(sexp_set_value(set)) = sexp_ref_name(ref); + generate(ctx, sexp_set_value(set)); + if (! sexp_lambdap(sexp_ref_loc(ref))) { + /* global vars are set directly */ + emit_push(ctx, sexp_ref_cell(ref)); + emit(ctx, OP_SET_CDR); + } else { + lambda = sexp_ref_loc(ref); + if (sexp_memq(ctx, sexp_ref_name(ref), sexp_lambda_sv(lambda)) + != SEXP_FALSE) { + /* stack or closure mutable vars are boxed */ + generate_ref(ctx, ref, 0); + emit(ctx, OP_SET_CDR); + } else { + /* internally defined variable */ + emit(ctx, OP_LOCAL_SET); + emit_word(ctx, sexp_param_index(lambda, sexp_ref_name(ref))); + } + } + sexp_context_depth(ctx)--; +} + +static void generate_opcode_app (sexp ctx, sexp app) { + sexp op = sexp_car(app); + sexp_sint_t i, num_args; + sexp_gc_var(ctx, ls, s_ls); + sexp_gc_preserve(ctx, ls, s_ls); + + num_args = sexp_unbox_integer(sexp_length(ctx, sexp_cdr(app))); + sexp_context_tailp(ctx) = 0; + + /* maybe push the default for an optional argument */ + if ((num_args == sexp_opcode_num_args(op)) + && sexp_opcode_variadic_p(op) + && sexp_opcode_default(op) + && (sexp_opcode_class(op) != OPC_PARAMETER)) { + emit_push(ctx, sexp_opcode_default(op)); + if (sexp_opcode_opt_param_p(op)) + emit(ctx, OP_CDR); + sexp_context_depth(ctx)++; + num_args++; + } + + /* push the arguments onto the stack */ + ls = ((sexp_opcode_inverse(op) + && (sexp_opcode_class(op) != OPC_ARITHMETIC_INV)) + ? sexp_cdr(app) : sexp_reverse(ctx, sexp_cdr(app))); + for ( ; sexp_pairp(ls); ls = sexp_cdr(ls)) + generate(ctx, sexp_car(ls)); + + /* emit the actual operator call */ + switch (sexp_opcode_class(op)) { + case OPC_ARITHMETIC: + if (num_args > 1) + emit(ctx, sexp_opcode_code(op)); + break; + case OPC_ARITHMETIC_INV: + emit(ctx, (num_args==1) ? sexp_opcode_inverse(op) : sexp_opcode_code(op)); + break; + case OPC_ARITHMETIC_CMP: + if (num_args > 2) { + emit(ctx, OP_STACK_REF); + emit_word(ctx, 2); + emit(ctx, OP_STACK_REF); + emit_word(ctx, 2); + emit(ctx, sexp_opcode_code(op)); + emit(ctx, OP_AND); + for (i=num_args-2; i>0; i--) { + emit(ctx, OP_STACK_REF); + emit_word(ctx, 3); + emit(ctx, OP_STACK_REF); + emit_word(ctx, 3); + emit(ctx, sexp_opcode_code(op)); + emit(ctx, OP_AND); + emit(ctx, OP_AND); + } + } else + emit(ctx, sexp_opcode_code(op)); + break; + case OPC_FOREIGN: + case OPC_TYPE_PREDICATE: + /* push the funtion pointer for foreign calls */ + emit(ctx, sexp_opcode_code(op)); + if (sexp_opcode_data(op)) + emit_word(ctx, (sexp_uint_t)sexp_opcode_data(op)); + break; + case OPC_PARAMETER: + emit_push(ctx, sexp_opcode_default(op)); + emit(ctx, ((num_args == 0) ? OP_CDR : OP_SET_CDR)); + break; + default: + emit(ctx, sexp_opcode_code(op)); + } + + /* emit optional folding of operator */ + if ((num_args > 2) + && (sexp_opcode_class(op) == OPC_ARITHMETIC + || sexp_opcode_class(op) == OPC_ARITHMETIC_INV)) + for (i=num_args-2; i>0; i--) + emit(ctx, sexp_opcode_code(op)); + + sexp_context_depth(ctx) -= (num_args-1); + sexp_gc_release(ctx, ls, s_ls); +} + +static void generate_general_app (sexp ctx, sexp app) { + sexp_uint_t len = sexp_unbox_integer(sexp_length(ctx, sexp_cdr(app))), + tailp = sexp_context_tailp(ctx); + sexp_gc_var(ctx, ls, s_ls); + sexp_gc_preserve(ctx, ls, s_ls); + + /* push the arguments onto the stack */ + sexp_context_tailp(ctx) = 0; + for (ls=sexp_reverse(ctx, sexp_cdr(app)); sexp_pairp(ls); ls=sexp_cdr(ls)) + generate(ctx, sexp_car(ls)); + + /* push the operator onto the stack */ + generate(ctx, sexp_car(app)); + + /* maybe overwrite the current frame */ + emit(ctx, (tailp ? OP_TAIL_CALL : OP_CALL)); + emit_word(ctx, (sexp_uint_t)sexp_make_integer(len)); + + sexp_context_depth(ctx) -= len; + sexp_gc_release(ctx, ls, s_ls); +} + +static void generate_app (sexp ctx, sexp app) { + if (sexp_opcodep(sexp_car(app))) + generate_opcode_app(ctx, app); + else + generate_general_app(ctx, app); +} + +static void generate_lambda (sexp ctx, sexp lambda) { + sexp ctx2, fv, ls, flags, len, ref, prev_lambda, prev_fv; + sexp_uint_t k; + sexp_gc_var(ctx, tmp, s_tmp); + sexp_gc_var(ctx, bc, s_bc); + sexp_gc_preserve(ctx, tmp, s_tmp); + sexp_gc_preserve(ctx, bc, s_bc); + prev_lambda = sexp_context_lambda(ctx); + prev_fv = sexp_lambdap(prev_lambda) ? sexp_lambda_fv(prev_lambda) : SEXP_NULL; + fv = sexp_lambda_fv(lambda); + ctx2 = sexp_make_context(ctx, sexp_context_stack(ctx), sexp_context_env(ctx)); + sexp_context_lambda(ctx2) = lambda; + /* allocate space for local vars */ + for (ls=sexp_lambda_locals(lambda); sexp_pairp(ls); ls=sexp_cdr(ls)) + emit_push(ctx2, SEXP_VOID); + /* box mutable vars */ + for (ls=sexp_lambda_sv(lambda); sexp_pairp(ls); ls=sexp_cdr(ls)) { + k = sexp_param_index(lambda, sexp_car(ls)); + if (k >= 0) { + emit(ctx2, OP_LOCAL_REF); + emit_word(ctx2, k); + emit_push(ctx2, sexp_car(ls)); + emit(ctx2, OP_CONS); + emit(ctx2, OP_LOCAL_SET); + emit_word(ctx2, k); + emit(ctx2, OP_DROP); + } + } + sexp_context_tailp(ctx2) = 1; + generate(ctx2, sexp_lambda_body(lambda)); + flags = sexp_make_integer((sexp_listp(ctx2, sexp_lambda_params(lambda)) + == SEXP_FALSE) ? 1uL : 0uL); + len = sexp_length(ctx2, sexp_lambda_params(lambda)); + bc = finalize_bytecode(ctx2); + sexp_bytecode_name(bc) = sexp_lambda_name(lambda); + if (sexp_nullp(fv)) { + /* shortcut, no free vars */ + tmp = sexp_make_vector(ctx2, sexp_make_integer(0), SEXP_VOID); + tmp = sexp_make_procedure(ctx2, flags, len, bc, tmp); + sexp_push(ctx, sexp_bytecode_literals(sexp_context_bc(ctx)), tmp); + generate_lit(ctx, tmp); + } else { + /* push the closed vars */ + emit_push(ctx, SEXP_VOID); + emit_push(ctx, sexp_length(ctx, fv)); + emit(ctx, OP_MAKE_VECTOR); + sexp_context_depth(ctx)--; + for (k=0; sexp_pairp(fv); fv=sexp_cdr(fv), k++) { + ref = sexp_car(fv); + generate_non_global_ref(ctx, sexp_ref_name(ref), sexp_ref_cell(ref), + prev_lambda, prev_fv, 0); + emit_push(ctx, sexp_make_integer(k)); + emit(ctx, OP_STACK_REF); + emit_word(ctx, 3); + emit(ctx, OP_VECTOR_SET); + emit(ctx, OP_DROP); + sexp_context_depth(ctx)--; + } + /* push the additional procedure info and make the closure */ + emit_push(ctx, bc); + emit_push(ctx, len); + emit_push(ctx, flags); + emit(ctx, OP_MAKE_PROCEDURE); + } + sexp_gc_release(ctx, tmp, s_tmp); +} + +static void generate (sexp ctx, sexp x) { + if (sexp_pointerp(x)) { + switch (sexp_pointer_tag(x)) { + case SEXP_PAIR: generate_app(ctx, x); break; + case SEXP_LAMBDA: generate_lambda(ctx, x); break; + case SEXP_CND: generate_cnd(ctx, x); break; + case SEXP_REF: generate_ref(ctx, x, 1); break; + case SEXP_SET: generate_set(ctx, x); break; + case SEXP_SEQ: generate_seq(ctx, sexp_seq_ls(x)); break; + case SEXP_LIT: generate_lit(ctx, sexp_lit_value(x)); break; + default: generate_lit(ctx, x); + } + } else { + generate_lit(ctx, x); + } +} + +static sexp insert_free_var (sexp ctx, sexp x, sexp fv) { + sexp name=sexp_ref_name(x), loc=sexp_ref_loc(x), ls; + for (ls=fv; sexp_pairp(ls); ls=sexp_cdr(ls)) + if ((name == sexp_ref_name(sexp_car(ls))) + && (loc == sexp_ref_loc(sexp_car(ls)))) + return fv; + return sexp_cons(ctx, x, fv); +} + +static sexp union_free_vars (sexp ctx, sexp fv1, sexp fv2) { + sexp_gc_var(ctx, res, s_res); + if (sexp_nullp(fv2)) + return fv1; + sexp_gc_preserve(ctx, res, s_res); + for (res=fv2; sexp_pairp(fv1); fv1=sexp_cdr(fv1)) + res = insert_free_var(ctx, sexp_car(fv1), res); + sexp_gc_release(ctx, res, s_res); + return res; +} + +static sexp diff_free_vars (sexp ctx, sexp lambda, sexp fv, sexp params) { + sexp_gc_var(ctx, res, s_res); + sexp_gc_preserve(ctx, res, s_res); + res = SEXP_NULL; + for ( ; sexp_pairp(fv); fv=sexp_cdr(fv)) + if ((sexp_ref_loc(sexp_car(fv)) != lambda) + || (sexp_memq(NULL, sexp_ref_name(sexp_car(fv)), params) + == SEXP_FALSE)) + sexp_push(ctx, res, sexp_car(fv)); + sexp_gc_release(ctx, res, s_res); + return res; +} + +static sexp free_vars (sexp ctx, sexp x, sexp fv) { + sexp_gc_var(ctx, fv1, s_fv1); + sexp_gc_var(ctx, fv2, s_fv2); + sexp_gc_preserve(ctx, fv1, s_fv1); + sexp_gc_preserve(ctx, fv2, s_fv2); + fv1 = fv; + if (sexp_lambdap(x)) { + fv1 = free_vars(ctx, sexp_lambda_body(x), SEXP_NULL); + fv2 = sexp_flatten_dot(ctx, sexp_lambda_params(x)); + fv2 = sexp_append2(ctx, sexp_lambda_locals(x), fv2); + fv2 = diff_free_vars(ctx, x, fv1, fv2); + sexp_lambda_fv(x) = fv2; + fv1 = union_free_vars(ctx, fv2, fv); + } else if (sexp_pairp(x)) { + for ( ; sexp_pairp(x); x=sexp_cdr(x)) + fv1 = free_vars(ctx, sexp_car(x), fv1); + } else if (sexp_cndp(x)) { + fv1 = free_vars(ctx, sexp_cnd_test(x), fv); + fv1 = free_vars(ctx, sexp_cnd_pass(x), fv1); + fv1 = free_vars(ctx, sexp_cnd_fail(x), fv1); + } else if (sexp_seqp(x)) { + for (x=sexp_seq_ls(x); sexp_pairp(x); x=sexp_cdr(x)) + fv1 = free_vars(ctx, sexp_car(x), fv1); + } else if (sexp_setp(x)) { + fv1 = free_vars(ctx, sexp_set_value(x), fv); + fv1 = free_vars(ctx, sexp_set_var(x), fv1); + } else if (sexp_refp(x) && sexp_lambdap(sexp_ref_loc(x))) { + fv1 = insert_free_var(ctx, x, fv); + } else if (sexp_synclop(x)) { + fv1 = free_vars(ctx, sexp_synclo_expr(x), fv); + } + sexp_gc_release(ctx, fv1, s_fv1); + return fv1; +} + +static sexp make_param_list(sexp ctx, sexp_uint_t i) { + sexp_gc_var(ctx, res, s_res); + sexp_gc_preserve(ctx, res, s_res); + res = SEXP_NULL; + for ( ; i>0; i--) + res = sexp_cons(ctx, sexp_make_integer(i), res); + sexp_gc_release(ctx, res, s_res); + return res; +} + +static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i) { + sexp ls, bc, res, env; + sexp_gc_var(ctx, params, s_params); + sexp_gc_var(ctx, ref, s_ref); + sexp_gc_var(ctx, refs, s_refs); + sexp_gc_var(ctx, lambda, s_lambda); + sexp_gc_var(ctx, ctx2, s_ctx2); + if (i == sexp_opcode_num_args(op) && sexp_opcode_proc(op)) + return sexp_opcode_proc(op); /* return before preserving */ + sexp_gc_preserve(ctx, params, s_params); + sexp_gc_preserve(ctx, ref, s_ref); + sexp_gc_preserve(ctx, refs, s_refs); + sexp_gc_preserve(ctx, lambda, s_lambda); + sexp_gc_preserve(ctx, ctx2, s_ctx2); + params = make_param_list(ctx, i); + lambda = sexp_make_lambda(ctx, params); + ctx2 = sexp_make_child_context(ctx, lambda); + env = extend_env(ctx2, sexp_context_env(ctx), params, lambda); + sexp_context_env(ctx2) = env; + for (ls=params, refs=SEXP_NULL; sexp_pairp(ls); ls=sexp_cdr(ls)) { + ref = sexp_make_ref(ctx2, sexp_car(ls), env_cell(env, sexp_car(ls))); + sexp_push(ctx2, refs, ref); + } + refs = sexp_reverse(ctx2, refs); + refs = sexp_cons(ctx2, op, refs); + generate_opcode_app(ctx2, refs); + bc = finalize_bytecode(ctx2); + sexp_bytecode_name(bc) = sexp_c_string(ctx2, sexp_opcode_name(op), -1); + res = sexp_make_procedure(ctx2, sexp_make_integer(0), sexp_make_integer(i), + bc, SEXP_VOID); + if (i == sexp_opcode_num_args(op)) + sexp_opcode_proc(op) = res; + sexp_gc_release(ctx, params, s_params); + return res; +} + +/*********************** the virtual machine **************************/ + +static sexp sexp_save_stack(sexp ctx, sexp *stack, sexp_uint_t to) { + sexp res, *data; + sexp_uint_t i; + res = sexp_make_vector(ctx, sexp_make_integer(to), SEXP_VOID); + data = sexp_vector_data(res); + for (i=0; i= INIT_STACK_SIZE) + errx(70, "out of stack space\n"); +#endif + i = sexp_unbox_integer(_WORD0); + tmp1 = _ARG1; + make_call: + if (sexp_opcodep(tmp1)) { + /* compile non-inlined opcode applications on the fly */ + sexp_context_top(ctx) = top; + tmp1 = make_opcode_procedure(ctx, tmp1, i); + if (sexp_exceptionp(tmp1)) { + _ARG1 = tmp1; + goto call_error_handler; + } + } + if (! sexp_procedurep(tmp1)) + sexp_raise("non procedure application", sexp_list1(ctx, tmp1)); + j = i - sexp_unbox_integer(sexp_procedure_num_args(tmp1)); + if (j < 0) + sexp_raise("not enough args", + sexp_list2(ctx, tmp1, sexp_make_integer(i))); + if (j > 0) { + if (sexp_procedure_variadic_p(tmp1)) { + stack[top-i-1] = sexp_cons(ctx, stack[top-i-1], SEXP_NULL); + for (k=top-i; k=top-i; k--) + stack[k] = stack[k-1]; + stack[top-i-1] = SEXP_NULL; + top++; + i++; + } + _ARG1 = sexp_make_integer(i); + stack[top] = sexp_make_integer(ip+sizeof(sexp)-sexp_bytecode_data(bc)); + stack[top+1] = self; + stack[top+2] = sexp_make_integer(fp); + top += 3; + self = tmp1; + bc = sexp_procedure_code(self); + ip = sexp_bytecode_data(bc); + cp = sexp_procedure_vars(self); + fp = top-4; + break; + case OP_FCALL0: + sexp_context_top(ctx) = top; + _PUSH(((sexp_proc1)_UWORD0)(ctx)); + ip += sizeof(sexp); + sexp_check_exception(); + break; + case OP_FCALL1: + sexp_context_top(ctx) = top; + _ARG1 = ((sexp_proc2)_UWORD0)(ctx, _ARG1); + ip += sizeof(sexp); + sexp_check_exception(); + break; + case OP_FCALL2: + sexp_context_top(ctx) = top; + _ARG2 = ((sexp_proc3)_UWORD0)(ctx, _ARG1, _ARG2); + top--; + ip += sizeof(sexp); + sexp_check_exception(); + break; + case OP_FCALL3: + sexp_context_top(ctx) = top; + _ARG3 =((sexp_proc4)_UWORD0)(ctx, _ARG1, _ARG2, _ARG3); + top -= 2; + ip += sizeof(sexp); + sexp_check_exception(); + break; + case OP_FCALL4: + sexp_context_top(ctx) = top; + _ARG4 =((sexp_proc5)_UWORD0)(ctx, _ARG1, _ARG2, _ARG3, _ARG4); + top -= 3; + ip += sizeof(sexp); + sexp_check_exception(); + break; + case OP_FCALL5: + sexp_context_top(ctx) = top; + _ARG5 =((sexp_proc6)_UWORD0)(ctx, _ARG1, _ARG2, _ARG3, _ARG4, _ARG5); + top -= 4; + ip += sizeof(sexp); + sexp_check_exception(); + break; + case OP_FCALL6: + sexp_context_top(ctx) = top; + _ARG6 =((sexp_proc7)_UWORD0)(ctx, _ARG1, _ARG2, _ARG3, _ARG4, _ARG5, _ARG6); + top -= 5; + ip += sizeof(sexp); + sexp_check_exception(); + break; + case OP_EVAL: + sexp_context_top(ctx) = top; + _ARG1 = sexp_eval(ctx, _ARG1); + sexp_check_exception(); + break; + case OP_JUMP_UNLESS: + if (stack[--top] == SEXP_FALSE) + ip += _SWORD0; + else + ip += sizeof(sexp_sint_t); + break; + case OP_JUMP: + ip += _SWORD0; + break; + case OP_PUSH: + _PUSH(_WORD0); + ip += sizeof(sexp); + break; + case OP_DROP: + top--; + break; + case OP_GLOBAL_REF: + if (sexp_cdr(_WORD0) == SEXP_UNDEF) + sexp_raise("undefined variable", sexp_list1(ctx, sexp_car(_WORD0))); + /* ... FALLTHROUGH ... */ + case OP_GLOBAL_KNOWN_REF: + _PUSH(sexp_cdr(_WORD0)); + ip += sizeof(sexp); + break; + case OP_STACK_REF: /* `pick' in forth */ + stack[top] = stack[top - _SWORD0]; + ip += sizeof(sexp); + top++; + break; + case OP_LOCAL_REF: + stack[top] = stack[fp - 1 - _SWORD0]; + ip += sizeof(sexp); + top++; + break; + case OP_LOCAL_SET: + stack[fp - 1 - _SWORD0] = _ARG1; + _ARG1 = SEXP_VOID; + ip += sizeof(sexp); + break; + case OP_CLOSURE_REF: + _PUSH(sexp_vector_ref(cp, sexp_make_integer(_WORD0))); + ip += sizeof(sexp); + break; + case OP_VECTOR_REF: + if (! sexp_vectorp(_ARG1)) + sexp_raise("vector-ref: not a vector", sexp_list1(ctx, _ARG1)); + _ARG2 = sexp_vector_ref(_ARG1, _ARG2); + top--; + break; + case OP_VECTOR_SET: + if (! sexp_vectorp(_ARG1)) + sexp_raise("vector-set!: not a vector", sexp_list1(ctx, _ARG1)); + sexp_vector_set(_ARG1, _ARG2, _ARG3); + _ARG3 = SEXP_VOID; + top-=2; + break; + case OP_VECTOR_LENGTH: + _ARG1 = sexp_make_integer(sexp_vector_length(_ARG1)); + break; + case OP_STRING_REF: + _ARG2 = sexp_string_ref(_ARG1, _ARG2); + top--; + break; + case OP_STRING_SET: + sexp_string_set(_ARG1, _ARG2, _ARG3); + _ARG3 = SEXP_VOID; + top-=2; + break; + case OP_STRING_LENGTH: + _ARG1 = sexp_make_integer(sexp_string_length(_ARG1)); + break; + case OP_MAKE_PROCEDURE: + sexp_context_top(ctx) = top; + _ARG4 = sexp_make_procedure(ctx, _ARG1, _ARG2, _ARG3, _ARG4); + top-=3; + break; + case OP_MAKE_VECTOR: + sexp_context_top(ctx) = top; + _ARG2 = sexp_make_vector(ctx, _ARG1, _ARG2); + top--; + break; + case OP_AND: + _ARG2 = sexp_make_boolean((_ARG1 != SEXP_FALSE) && (_ARG2 != SEXP_FALSE)); + top--; + break; + case OP_EOFP: + _ARG1 = sexp_make_boolean(_ARG1 == SEXP_EOF); break; + case OP_NULLP: + _ARG1 = sexp_make_boolean(sexp_nullp(_ARG1)); break; + case OP_INTEGERP: + _ARG1 = sexp_make_boolean(sexp_integerp(_ARG1)); break; + case OP_SYMBOLP: + _ARG1 = sexp_make_boolean(sexp_symbolp(_ARG1)); break; + case OP_CHARP: + _ARG1 = sexp_make_boolean(sexp_charp(_ARG1)); break; + case OP_TYPEP: + _ARG1 = sexp_make_boolean(sexp_pointerp(_ARG1) + && (sexp_pointer_tag(_ARG1) + == _UWORD0)); + ip += sizeof(sexp); + break; + case OP_CAR: + if (! sexp_pairp(_ARG1)) + sexp_raise("car: not a pair", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_car(_ARG1); break; + case OP_CDR: + if (! sexp_pairp(_ARG1)) + sexp_raise("cdr: not a pair", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_cdr(_ARG1); break; + case OP_SET_CAR: + if (! sexp_pairp(_ARG1)) + sexp_raise("set-car!: not a pair", sexp_list1(ctx, _ARG1)); + sexp_car(_ARG1) = _ARG2; + _ARG2 = SEXP_VOID; + top--; + break; + case OP_SET_CDR: + if (! sexp_pairp(_ARG1)) + sexp_raise("set-cdr!: not a pair", sexp_list1(ctx, _ARG1)); + sexp_cdr(_ARG1) = _ARG2; + _ARG2 = SEXP_VOID; + top--; + break; + case OP_CONS: + sexp_context_top(ctx) = top; + _ARG2 = sexp_cons(ctx, _ARG1, _ARG2); + top--; + break; + case OP_ADD: + if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) + _ARG2 = sexp_fx_add(_ARG1, _ARG2); +#if USE_FLONUMS + else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_fp_add(ctx, _ARG1, _ARG2); + else if (sexp_flonump(_ARG1) && sexp_integerp(_ARG2)) + _ARG2 = sexp_make_flonum(ctx, sexp_flonum_value(_ARG1) + (double)sexp_unbox_integer(_ARG2)); + else if (sexp_integerp(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_make_flonum(ctx, (double)sexp_unbox_integer(_ARG1) + sexp_flonum_value(_ARG2)); +#endif + else sexp_raise("+: not a number", sexp_list2(ctx, _ARG1, _ARG2)); + top--; + break; + case OP_SUB: + if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) + _ARG2 = sexp_fx_sub(_ARG1, _ARG2); +#if USE_FLONUMS + else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_fp_sub(ctx, _ARG1, _ARG2); + else if (sexp_flonump(_ARG1) && sexp_integerp(_ARG2)) + _ARG2 = sexp_make_flonum(ctx, sexp_flonum_value(_ARG1) - (double)sexp_unbox_integer(_ARG2)); + else if (sexp_integerp(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_make_flonum(ctx, (double)sexp_unbox_integer(_ARG1) - sexp_flonum_value(_ARG2)); +#endif + else sexp_raise("-: not a number", sexp_list2(ctx, _ARG1, _ARG2)); + top--; + break; + case OP_MUL: + if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) + _ARG2 = sexp_fx_mul(_ARG1, _ARG2); +#if USE_FLONUMS + else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_fp_mul(ctx, _ARG1, _ARG2); + else if (sexp_flonump(_ARG1) && sexp_integerp(_ARG2)) + _ARG2 = sexp_make_flonum(ctx, sexp_flonum_value(_ARG1) * (double)sexp_unbox_integer(_ARG2)); + else if (sexp_integerp(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_make_flonum(ctx, (double)sexp_unbox_integer(_ARG1) * sexp_flonum_value(_ARG2)); +#endif + else sexp_raise("*: not a number", sexp_list2(ctx, _ARG1, _ARG2)); + top--; + break; + case OP_DIV: + if (_ARG2 == sexp_make_integer(0)) + sexp_raise("divide by zero", SEXP_NULL); + if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) { +#if USE_FLONUMS + _ARG1 = sexp_integer_to_flonum(ctx, _ARG1); + _ARG2 = sexp_integer_to_flonum(ctx, _ARG2); + _ARG2 = sexp_fp_div(ctx, _ARG1, _ARG2); +#else + _ARG2 = sexp_fx_div(_ARG1, _ARG2); +#endif + } +#if USE_FLONUMS + else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_fp_div(ctx, _ARG1, _ARG2); + else if (sexp_flonump(_ARG1) && sexp_integerp(_ARG2)) + _ARG2 = sexp_make_flonum(ctx, sexp_flonum_value(_ARG1) / (double)sexp_unbox_integer(_ARG2)); + else if (sexp_integerp(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_make_flonum(ctx, (double)sexp_unbox_integer(_ARG1) / sexp_flonum_value(_ARG2)); +#endif + else sexp_raise("/: not a number", sexp_list2(ctx, _ARG1, _ARG2)); + top--; + break; + case OP_QUOTIENT: + if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) { + if (_ARG2 == sexp_make_integer(0)) + sexp_raise("divide by zero", SEXP_NULL); + _ARG2 = sexp_fx_div(_ARG1, _ARG2); + top--; + } + else sexp_raise("quotient: not an integer", sexp_list2(ctx, _ARG1, _ARG2)); + break; + case OP_REMAINDER: + if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) { + if (_ARG2 == sexp_make_integer(0)) + sexp_raise("divide by zero", SEXP_NULL); + tmp1 = sexp_fx_rem(_ARG1, _ARG2); + top--; + _ARG1 = tmp1; + } + else sexp_raise("remainder: not an integer", sexp_list2(ctx, _ARG1, _ARG2)); + break; + case OP_NEGATIVE: + if (sexp_integerp(_ARG1)) + _ARG1 = sexp_make_integer(-sexp_unbox_integer(_ARG1)); +#if USE_FLONUMS + else if (sexp_flonump(_ARG1)) + _ARG1 = sexp_make_flonum(ctx, -sexp_flonum_value(_ARG1)); +#endif + else sexp_raise("-: not a number", sexp_list1(ctx, _ARG1)); + break; + case OP_INVERSE: + if (sexp_integerp(_ARG1)) + _ARG1 = sexp_make_flonum(ctx, 1/(double)sexp_unbox_integer(_ARG1)); +#if USE_FLONUMS + else if (sexp_flonump(_ARG1)) + _ARG1 = sexp_make_flonum(ctx, 1/sexp_flonum_value(_ARG1)); +#endif + else sexp_raise("/: not a number", sexp_list1(ctx, _ARG1)); + break; + case OP_LT: + if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) + i = (sexp_sint_t)_ARG1 < (sexp_sint_t)_ARG2; +#if USE_FLONUMS + else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) + i = sexp_flonum_value(_ARG1) < sexp_flonum_value(_ARG2); + else if (sexp_flonump(_ARG1) && sexp_integerp(_ARG2)) + i = sexp_flonum_value(_ARG1) < (double)sexp_unbox_integer(_ARG2); + else if (sexp_integerp(_ARG1) && sexp_flonump(_ARG2)) + i = (double)sexp_unbox_integer(_ARG1) < sexp_flonum_value(_ARG2); +#endif + else sexp_raise("<: not a number", sexp_list2(ctx, _ARG1, _ARG2)); + _ARG2 = sexp_make_boolean(i); + top--; + break; + case OP_LE: + if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) + i = (sexp_sint_t)_ARG1 <= (sexp_sint_t)_ARG2; +#if USE_FLONUMS + else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) + i = sexp_flonum_value(_ARG1) <= sexp_flonum_value(_ARG2); + else if (sexp_flonump(_ARG1) && sexp_integerp(_ARG2)) + i = sexp_flonum_value(_ARG1) <= (double)sexp_unbox_integer(_ARG2); + else if (sexp_integerp(_ARG1) && sexp_flonump(_ARG2)) + i = (double)sexp_unbox_integer(_ARG1) <= sexp_flonum_value(_ARG2); +#endif + else sexp_raise("<=: not a number", sexp_list2(ctx, _ARG1, _ARG2)); + _ARG2 = sexp_make_boolean(i); + top--; + break; + case OP_EQN: + if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) + i = _ARG1 == _ARG2; +#if USE_FLONUMS + else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) + i = sexp_flonum_value(_ARG1) == sexp_flonum_value(_ARG2); + else if (sexp_flonump(_ARG1) && sexp_integerp(_ARG2)) + i = sexp_flonum_value(_ARG1) == (double)sexp_unbox_integer(_ARG2); + else if (sexp_integerp(_ARG1) && sexp_flonump(_ARG2)) + i = (double)sexp_unbox_integer(_ARG1) == sexp_flonum_value(_ARG2); +#endif + else sexp_raise("=: not a number", sexp_list2(ctx, _ARG1, _ARG2)); + _ARG2 = sexp_make_boolean(i); + top--; + break; + case OP_EQ: + _ARG2 = sexp_make_boolean(_ARG1 == _ARG2); + top--; + break; + case OP_FIX2FLO: + if (sexp_integerp(_ARG1)) + _ARG1 = sexp_integer_to_flonum(ctx, _ARG1); + else +#if USE_FLONUMS + if (! sexp_flonump(_ARG1)) +#endif + sexp_raise("exact->inexact: not a number", sexp_list1(ctx, _ARG1)); + break; + case OP_FLO2FIX: +#if USE_FLONUMS + if (sexp_flonump(_ARG1)) + _ARG1 = sexp_make_integer((sexp_sint_t)sexp_flonum_value(_ARG1)); + else +#endif + if (! sexp_integerp(_ARG1)) + sexp_raise("inexact->exact: not a number", sexp_list1(ctx, _ARG1)); + break; + case OP_CHAR2INT: + _ARG1 = sexp_make_integer(sexp_unbox_character(_ARG1)); + break; + case OP_INT2CHAR: + _ARG1 = sexp_make_character(sexp_unbox_integer(_ARG1)); + break; + case OP_CHAR_UPCASE: + _ARG1 = sexp_make_character(toupper(sexp_unbox_character(_ARG1))); + break; + case OP_CHAR_DOWNCASE: + _ARG1 = sexp_make_character(tolower(sexp_unbox_character(_ARG1))); + break; + case OP_DISPLAY: + if (sexp_stringp(_ARG1)) { + sexp_write_string(ctx, sexp_string_data(_ARG1), _ARG2); + _ARG2 = SEXP_VOID; + top--; + break; + } else if (sexp_charp(_ARG1)) { + sexp_write_char(ctx, sexp_unbox_character(_ARG1), _ARG2); + _ARG2 = SEXP_VOID; + top--; + break; + } + /* ... FALLTHROUGH ... */ + case OP_WRITE: + sexp_write(ctx, _ARG1, _ARG2); + _ARG2 = SEXP_VOID; + top--; + break; + case OP_WRITE_CHAR: + sexp_write_char(ctx, sexp_unbox_character(_ARG1), _ARG2); + _ARG2 = SEXP_VOID; + top--; + break; + case OP_NEWLINE: + sexp_newline(ctx, _ARG1); + _ARG1 = SEXP_VOID; + break; + case OP_FLUSH_OUTPUT: + sexp_flush(ctx, _ARG1); + _ARG1 = SEXP_VOID; + break; + case OP_READ: + sexp_context_top(ctx) = top; + _ARG1 = sexp_read(ctx, _ARG1); + sexp_check_exception(); + break; + case OP_READ_CHAR: + i = sexp_read_char(ctx, _ARG1); + _ARG1 = (i == EOF) ? SEXP_EOF : sexp_make_character(i); + break; + case OP_PEEK_CHAR: + i = sexp_read_char(ctx, _ARG1); + sexp_push_char(ctx, i, _ARG1); + _ARG1 = (i == EOF) ? SEXP_EOF : sexp_make_character(i); + break; + case OP_RET: + i = sexp_unbox_integer(stack[fp]); + stack[fp-i] = _ARG1; + top = fp-i+1; + self = stack[fp+2]; + bc = sexp_procedure_code(self); + ip = sexp_bytecode_data(bc) + sexp_unbox_integer(stack[fp+1]); + cp = sexp_procedure_vars(self); + fp = sexp_unbox_integer(stack[fp+3]); + break; + case OP_DONE: + goto end_loop; + default: + sexp_raise("unknown opcode", sexp_list1(ctx, sexp_make_integer(*(ip-1)))); + } + goto loop; + + end_loop: + sexp_gc_release(ctx, self, s_self); + sexp_context_top(ctx) = top; + return _ARG1; +} + +/************************ library procedures **************************/ + +static sexp sexp_exception_type_func (sexp ctx, sexp exn) { + if (sexp_exceptionp(exn)) + return sexp_exception_kind(exn); + else + return sexp_type_exception(ctx, "not an exception", exn); +} + +static sexp sexp_open_input_file (sexp ctx, sexp path) { + FILE *in; + if (! sexp_stringp(path)) + return sexp_type_exception(ctx, "not a string", path); + in = fopen(sexp_string_data(path), "r"); + if (! in) + return + sexp_user_exception(ctx, SEXP_FALSE, "couldn't open input file", path); + return sexp_make_input_port(ctx, in, path); +} + +static sexp sexp_open_output_file (sexp ctx, sexp path) { + FILE *out; + if (! sexp_stringp(path)) + return sexp_type_exception(ctx, "not a string", path); + out = fopen(sexp_string_data(path), "w"); + if (! out) + return + sexp_user_exception(ctx, SEXP_FALSE, "couldn't open output file", path); + return sexp_make_input_port(ctx, out, path); +} + +static sexp sexp_close_port (sexp ctx, sexp port) { + if (! sexp_portp(port)) + return sexp_type_exception(ctx, "not a port", port); + if (! sexp_port_openp(port)) + return sexp_user_exception(ctx, SEXP_FALSE, "port already closed", port); + if (sexp_port_buf(port)) + free(sexp_port_buf(port)); + if (sexp_port_stream(port)) + fclose(sexp_port_stream(port)); + sexp_port_openp(port) = 0; + return SEXP_VOID; +} + +void sexp_warn_undefs (sexp ctx, sexp from, sexp to, sexp out) { + sexp x; + for (x=from; sexp_pairp(x) && x!=to; x=sexp_cdr(x)) + if (sexp_cdar(x) == SEXP_UNDEF) { + sexp_write_string(ctx, "WARNING: reference to undefined variable: ", out); + sexp_write(ctx, sexp_caar(x), out); + sexp_write_char(ctx, '\n', out); + } +} + +sexp sexp_load (sexp ctx, sexp source, sexp env) { + sexp tmp, out; + sexp_gc_var(ctx, ctx2, s_ctx2); + sexp_gc_var(ctx, x, s_x); + sexp_gc_var(ctx, in, s_in); + sexp_gc_var(ctx, res, s_res); + sexp_gc_preserve(ctx, ctx2, s_ctx2); + sexp_gc_preserve(ctx, x, s_x); + sexp_gc_preserve(ctx, in, s_in); + sexp_gc_preserve(ctx, res, s_res); + res = SEXP_VOID; + in = sexp_open_input_file(ctx, source); + out = env_global_ref(env, the_cur_err_symbol, SEXP_FALSE); + ctx2 = sexp_make_context(ctx, NULL, env); + sexp_context_parent(ctx2) = ctx; + tmp = sexp_env_bindings(env); + sexp_context_tailp(ctx2) = 0; + if (sexp_exceptionp(in)) { + sexp_print_exception(ctx, in, out); + res = in; + } else { + sexp_port_sourcep(in) = 1; + while ((x=sexp_read(ctx, in)) != (sexp) SEXP_EOF) { + res = sexp_eval(ctx2, x); + if (sexp_exceptionp(res)) + break; + } + if (x == SEXP_EOF) + res = SEXP_VOID; + sexp_close_port(ctx, in); +#if USE_WARN_UNDEFS + if (sexp_oportp(out)) + sexp_warn_undefs(ctx, sexp_env_bindings(env), tmp, out); +#endif + } + sexp_gc_release(ctx, ctx2, s_ctx2); + return res; +} + +#if USE_MATH + +#define define_math_op(name, cname) \ + static sexp name (sexp ctx, sexp z) { \ + double d; \ + if (sexp_flonump(z)) \ + d = sexp_flonum_value(z); \ + else if (sexp_integerp(z)) \ + d = (double)sexp_unbox_integer(z); \ + else \ + return sexp_type_exception(ctx, "not a number", z); \ + return sexp_make_flonum(ctx, cname(d)); \ + } + +define_math_op(sexp_exp, exp) +define_math_op(sexp_log, log) +define_math_op(sexp_sin, sin) +define_math_op(sexp_cos, cos) +define_math_op(sexp_tan, tan) +define_math_op(sexp_asin, asin) +define_math_op(sexp_acos, acos) +define_math_op(sexp_atan, atan) +define_math_op(sexp_sqrt, sqrt) +define_math_op(sexp_round, round) +define_math_op(sexp_trunc, trunc) +define_math_op(sexp_floor, floor) +define_math_op(sexp_ceiling, ceil) + +#endif + +static sexp sexp_expt (sexp ctx, sexp x, sexp e) { + double res, x1, e1; + if (sexp_integerp(x)) + x1 = (double)sexp_unbox_integer(x); +#if USE_FLONUMS + else if (sexp_flonump(x)) + x1 = sexp_flonum_value(x); +#endif + else + return sexp_type_exception(ctx, "not a number", x); + if (sexp_integerp(e)) + e1 = (double)sexp_unbox_integer(e); +#if USE_FLONUMS + else if (sexp_flonump(e)) + e1 = sexp_flonum_value(e); +#endif + else + return sexp_type_exception(ctx, "not a number", e); + res = pow(x1, e1); +#if USE_FLONUMS + if ((res > SEXP_MAX_INT) || sexp_flonump(x) || sexp_flonump(e)) + return sexp_make_flonum(ctx, res); +#endif + return sexp_make_integer((sexp_sint_t)round(res)); +} + +static sexp sexp_string_cmp (sexp ctx, sexp str1, sexp str2, sexp ci) { + sexp_sint_t len1, len2, len, diff; + if (! sexp_stringp(str1)) + return sexp_type_exception(ctx, "not a string", str1); + if (! sexp_stringp(str2)) + return sexp_type_exception(ctx, "not a string", str2); + len1 = sexp_string_length(str1); + len2 = sexp_string_length(str2); + len = ((len1next) h = h->next; + return h; +} + +sexp_uint_t sexp_allocated_bytes (sexp x) { + sexp_uint_t res, *len_ptr; + sexp t; + if ((! sexp_pointerp(x)) || (sexp_pointer_tag(x) > SEXP_CONTEXT)) + return sexp_heap_align(1); + t = &(sexp_type_specs[sexp_pointer_tag(x)]); + len_ptr = (sexp_uint_t*) (((char*)x) + sexp_type_size_off(t)); + res = sexp_type_size_base(t) + len_ptr[0] * sexp_type_size_scale(t); + return res; +} + +void sexp_mark (sexp x) { + sexp_uint_t *len_ptr; + sexp_sint_t i, len; + sexp t, *p; + struct sexp_gc_var_t *saves; + loop: + if ((! x) || (! sexp_pointerp(x)) || sexp_gc_mark(x)) + return; + sexp_gc_mark(x) = 1; + if (sexp_contextp(x)) + for (saves=sexp_context_saves(x); saves; saves=saves->next) + if (saves->var) sexp_mark(*(saves->var)); + t = &(sexp_type_specs[sexp_pointer_tag(x)]); + p = (sexp*) (((char*)x) + sexp_type_field_base(t)); + len_ptr = (sexp_uint_t*) (((char*)x) + sexp_type_field_len_off(t)); + len = sexp_type_field_len_base(t) + + len_ptr[0]*sexp_type_field_len_scale(t) - 1; + if (len >= 0) { + for (i=0; inext) { + p = (sexp) (h->data + sexp_heap_align(sexp_sizeof(pair))); + q = h->free_list; + end = (char*)h->data + h->size; + while (((char*)p) < end) { + /* find the preceding and succeeding free list pointers */ + for (r=q->next; r && ((char*)r<(char*)p); q=r, r=r->next) + ; + if ((char*)r == (char*)p) { + p = (sexp) (((char*)p) + r->size); + continue; + } + size = sexp_heap_align(sexp_allocated_bytes(p)); + if ((! sexp_gc_mark(p)) && (! stack_references_pointer_p(ctx, p))) { + sum_freed += size; + if (((((char*)q) + q->size) == (char*)p) && (q != h->free_list)) { + /* merge q with p */ + if (r && ((((char*)p)+size) == (char*)r)) { + /* ... and with r */ + q->next = r->next; + freed = q->size + size + r->size; + p = (sexp) (((char*)p) + size + r->size); + } else { + freed = q->size + size; + p = (sexp) (((char*)p)+size); + } + q->size = freed; + } else { + s = (sexp_free_list)p; + if (r && ((((char*)p)+size) == (char*)r)) { + /* merge p with r */ + s->size = size + r->size; + s->next = r->next; + q->next = s; + freed = size + r->size; + } else { + s->size = size; + s->next = r; + q->next = s; + freed = size; + } + p = (sexp) (((char*)p)+freed); + } + if (freed > max_freed) + max_freed = freed; + } else { + sexp_gc_mark(p) = 0; + p = (sexp) (((char*)p)+size); + } + } + } + sum_freed_ptr[0] = sum_freed; + return sexp_make_integer(max_freed); +} + +sexp sexp_gc (sexp ctx, size_t *sum_freed) { + sexp res; + int i; + sexp_mark(continuation_resumer); + sexp_mark(final_resumer); + for (i=0; isize = size; + h->data = (char*) sexp_heap_align((sexp_uint_t)&(h->data)); + free = h->free_list = (sexp_free_list) h->data; + h->next = NULL; + next = (sexp_free_list) ((char*)free + sexp_heap_align(sexp_sizeof(pair))); + free->size = 0; /* actually sexp_sizeof(pair) */ + free->next = next; + next->size = size - sexp_heap_align(sexp_sizeof(pair)); + next->next = NULL; + return h; +} + +int sexp_grow_heap (sexp ctx, size_t size) { + size_t cur_size, new_size; + sexp_heap h = sexp_heap_last(heap); + cur_size = h->size; + new_size = sexp_heap_align(((cur_size > size) ? cur_size : size) * 2); + h->next = sexp_make_heap(new_size); + return (h->next != NULL); +} + +void* sexp_try_alloc (sexp ctx, size_t size) { + sexp_free_list ls1, ls2, ls3; + sexp_heap h; + for (h=heap; h; h=h->next) + for (ls1=h->free_list, ls2=ls1->next; ls2; ls1=ls2, ls2=ls2->next) + if (ls2->size >= size) { + if (ls2->size >= (size + SEXP_MINIMUM_OBJECT_SIZE)) { + ls3 = (sexp_free_list) (((char*)ls2)+size); /* the tail after ls2 */ + ls3->size = ls2->size - size; + ls3->next = ls2->next; + ls1->next = ls3; + } else { /* take the whole chunk */ + ls1->next = ls2->next; + } + memset((void*)ls2, 0, size); + return ls2; + } + return NULL; +} + +void* sexp_alloc (sexp ctx, size_t size) { + void *res; + size_t max_freed, sum_freed; + sexp_heap h; + size = sexp_heap_align(size); + res = sexp_try_alloc(ctx, size); + if (! res) { + max_freed = sexp_unbox_integer(sexp_gc(ctx, &sum_freed)); + h = sexp_heap_last(heap); + if (((max_freed < size) + || ((h->size - sum_freed) < (h->size*(1 - SEXP_GROW_HEAP_RATIO)))) + && ((! SEXP_MAXIMUM_HEAP_SIZE) || (size < SEXP_MAXIMUM_HEAP_SIZE))) + sexp_grow_heap(ctx, size); + res = sexp_try_alloc(ctx, size); + if (! res) + errx(80, "out of memory allocating %zu bytes, aborting\n", size); + } + return res; +} + +void sexp_gc_init () { + sexp_uint_t size = sexp_heap_align(SEXP_INITIAL_HEAP_SIZE); + heap = sexp_make_heap(size); +#if USE_DEBUG_GC + /* the +32 is a hack, but this is just for debugging anyway */ + stack_base = ((sexp*)&size) + 32; +#endif +} + diff --git a/include/chibi/config.h b/include/chibi/config.h new file mode 100644 index 00000000..e3fdf9b6 --- /dev/null +++ b/include/chibi/config.h @@ -0,0 +1,120 @@ +/* config.h -- general configuration */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +/* uncomment this to use the Boehm conservative GC */ +/* #define USE_BOEHM 1 */ + +/* uncomment this to just malloc manually instead of any GC */ +/* #define USE_MALLOC 1 */ + +/* uncomment this to add conservative checks to the native GC */ +/* #define USE_DEBUG_GC 1 */ + +/* uncomment this if you only want fixnum support */ +/* #define USE_FLONUMS 0 */ + +/* uncomment this if you want immediate flonums */ +/* #define USE_IMMEDIATE_FLONUMS 1 */ + +/* uncomment this if you don't need extended math operations */ +/* #define USE_MATH 0 */ + +/* uncomment this to disable warning about references to undefined variables */ +/* #define USE_WARN_UNDEFS 0 */ + +/* uncomment this to disable huffman-coded immediate symbols */ +/* #define USE_HUFF_SYMS 0 */ + +/* uncomment this to just use a single list for hash tables */ +/* #define USE_HASH_SYMS 0 */ + +/* uncomment this to disable string ports */ +/* #define USE_STRING_STREAMS 0 */ + +/* uncomment this to enable stack overflow checks */ +/* #define USE_CHECK_STACK 1 */ + +/* uncomment this to disable debugging utilities */ +/* #define USE_DEBUG 0 */ + +/************************************************************************/ +/* DEFAULTS - DO NOT MODIFY ANYTHING BELOW THIS LINE */ +/************************************************************************/ + +#if defined(__APPLE__) || defined(__FreeBSD__) || defined(__NetBSD__) || defined(__DragonFly__) || defined(__OpenBSD__) +#define SEXP_BSD 1 +#else +#define SEXP_BSD 0 +#define _GNU_SOURCE +#endif + +#ifndef USE_BOEHM +#define USE_BOEHM 0 +#endif + +#ifndef USE_MALLOC +#define USE_MALLOC 0 +#endif + +#ifndef USE_DEBUG_GC +#define USE_DEBUG_GC 0 +#endif + +#ifndef USE_FLONUMS +#define USE_FLONUMS 1 +#endif + +#ifndef USE_IMMEDIATE_FLONUMS +#define USE_IMMEDIATE_FLONUMS 0 +#endif + +#ifndef USE_MATH +#define USE_MATH 1 +#endif + +#ifndef USE_WARN_UNDEFS +#define USE_WARN_UNDEFS 1 +#endif + +#ifndef USE_HUFF_SYMS +#define USE_HUFF_SYMS 1 +#endif + +#ifndef USE_HASH_SYMS +#define USE_HASH_SYMS 1 +#endif + +#ifndef USE_DEBUG +#define USE_DEBUG 1 +#endif + +#ifndef USE_STRING_STREAMS +#define USE_STRING_STREAMS 1 +#endif + +#ifndef USE_CHECK_STACK +#define USE_CHECK_STACK 0 +#endif + +#ifdef PLAN9 + +#define errx(code, msg, ...) exits(msg) +#define exit_normally() exits(NULL) +#define strcasecmp cistrcmp +#define strncasecmp cistrncmp +/* XXXX these are wrong */ +#define trunc floor +#define round(x) floor(x+0.5) + +#else + +#define exit_normally() exit(0) +#if HAVE_ERR_H +#include +#else +/* requires msg be a string literal, and at least one argument */ +#define errx(code, msg, ...) (fprintf(stderr,msg"\n",__VA_ARGS__), exit(code)) +#endif + +#endif diff --git a/include/chibi/eval.h b/include/chibi/eval.h new file mode 100644 index 00000000..1b51c8f5 --- /dev/null +++ b/include/chibi/eval.h @@ -0,0 +1,140 @@ +/* eval.h -- headers for eval library */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#ifndef SEXP_EVAL_H +#define SEXP_EVAL_H + +#include "chibi/sexp.h" + +/************************* additional types ***************************/ + +#define INIT_BCODE_SIZE 128 +#define INIT_STACK_SIZE 1024 + +#define sexp_init_file "init.scm" + +/* procedure types */ +typedef sexp (*sexp_proc0) (); +typedef sexp (*sexp_proc1) (sexp); +typedef sexp (*sexp_proc2) (sexp, sexp); +typedef sexp (*sexp_proc3) (sexp, sexp, sexp); +typedef sexp (*sexp_proc4) (sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc5) (sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc6) (sexp, sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc7) (sexp, sexp, sexp, sexp, sexp, sexp, sexp); + +enum core_form_names { + CORE_DEFINE = 1, + CORE_SET, + CORE_LAMBDA, + CORE_IF, + CORE_BEGIN, + CORE_QUOTE, + CORE_DEFINE_SYNTAX, + CORE_LET_SYNTAX, + CORE_LETREC_SYNTAX, +}; + +enum opcode_classes { + OPC_GENERIC = 1, + OPC_TYPE_PREDICATE, + OPC_PREDICATE, + OPC_ARITHMETIC, + OPC_ARITHMETIC_INV, + OPC_ARITHMETIC_CMP, + OPC_IO, + OPC_CONSTRUCTOR, + OPC_ACCESSOR, + OPC_PARAMETER, + OPC_FOREIGN, +}; + +enum opcode_names { + OP_NOOP, + OP_RAISE, + OP_RESUMECC, + OP_CALLCC, + OP_APPLY1, + OP_TAIL_CALL, + OP_CALL, + OP_FCALL0, + OP_FCALL1, + OP_FCALL2, + OP_FCALL3, + OP_FCALL4, + OP_FCALL5, + OP_FCALL6, + OP_EVAL, + OP_JUMP_UNLESS, + OP_JUMP, + OP_PUSH, + OP_DROP, + OP_GLOBAL_REF, + OP_GLOBAL_KNOWN_REF, + OP_STACK_REF, + OP_LOCAL_REF, + OP_LOCAL_SET, + OP_CLOSURE_REF, + OP_VECTOR_REF, + OP_VECTOR_SET, + OP_VECTOR_LENGTH, + OP_STRING_REF, + OP_STRING_SET, + OP_STRING_LENGTH, + OP_MAKE_PROCEDURE, + OP_MAKE_VECTOR, + OP_AND, + OP_NULLP, + OP_INTEGERP, + OP_SYMBOLP, + OP_CHARP, + OP_EOFP, + OP_TYPEP, + OP_CAR, + OP_CDR, + OP_SET_CAR, + OP_SET_CDR, + OP_CONS, + OP_ADD, + OP_SUB, + OP_MUL, + OP_DIV, + OP_QUOTIENT, + OP_REMAINDER, + OP_NEGATIVE, + OP_INVERSE, + OP_LT, + OP_LE, + OP_EQN, + OP_EQ, + OP_FIX2FLO, + OP_FLO2FIX, + OP_CHAR2INT, + OP_INT2CHAR, + OP_CHAR_UPCASE, + OP_CHAR_DOWNCASE, + OP_DISPLAY, + OP_WRITE, + OP_WRITE_CHAR, + OP_NEWLINE, + OP_FLUSH_OUTPUT, + OP_READ, + OP_READ_CHAR, + OP_PEEK_CHAR, + OP_RET, + OP_DONE, +}; + +/**************************** prototypes ******************************/ + +void sexp_scheme_init(); +sexp sexp_apply(sexp context, sexp proc, sexp args); +sexp sexp_eval(sexp context, sexp obj); +sexp sexp_eval_string(sexp context, char *str); +sexp sexp_load(sexp context, sexp expr, sexp env); +sexp sexp_make_context(sexp context, sexp stack, sexp env); +void sexp_warn_undefs(sexp ctx, sexp from, sexp to, sexp out); + +#endif /* ! SEXP_EVAL_H */ + diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h new file mode 100644 index 00000000..8ab96d98 --- /dev/null +++ b/include/chibi/sexp.h @@ -0,0 +1,590 @@ +/* sexp.h -- header for sexp library */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#ifndef SEXP_H +#define SEXP_H + +#include "chibi/config.h" +#include "chibi/install.h" + +#include +#include +#ifdef PLAN9 +typedef unsigned long size_t; +#define offsetof(st, m) ((size_t) ((char*)&((st*)(0))->m - (char*)0)) +#else +#include +#include +#include +#include +#include +#include +#endif + +/* tagging system + * bits end in 00: pointer + * 01: fixnum + * 011: immediate flonum (optional) + * 111: immediate symbol (optional) + * 0110: char + * 1110: other immediate object (NULL, TRUE, FALSE) + */ + +#define SEXP_FIXNUM_BITS 2 +#define SEXP_IMMEDIATE_BITS 3 +#define SEXP_EXTENDED_BITS 4 + +#define SEXP_FIXNUM_MASK 3 +#define SEXP_IMMEDIATE_MASK 7 +#define SEXP_EXTENDED_MASK 15 + +#define SEXP_POINTER_TAG 0 +#define SEXP_FIXNUM_TAG 1 +#define SEXP_ISYMBOL_TAG 7 +#define SEXP_IFLONUM_TAG 3 +#define SEXP_CHAR_TAG 6 +#define SEXP_EXTENDED_TAG 14 + +#define SEXP_MAX_INT ((1<<29)-1) +#define SEXP_MIN_INT (-(1<<29)) + +#if USE_HASH_SYMS +#define SEXP_SYMBOL_TABLE_SIZE 389 +#else +#define SEXP_SYMBOL_TABLE_SIZE 1 +#endif + +enum sexp_types { + SEXP_OBJECT, + SEXP_TYPE, + SEXP_FIXNUM, + SEXP_CHAR, + SEXP_BOOLEAN, + SEXP_PAIR, + SEXP_SYMBOL, + SEXP_STRING, + SEXP_VECTOR, + SEXP_FLONUM, + SEXP_BIGNUM, + SEXP_IPORT, + SEXP_OPORT, + SEXP_EXCEPTION, + SEXP_PROCEDURE, + SEXP_MACRO, + SEXP_SYNCLO, + SEXP_ENV, + SEXP_BYTECODE, + SEXP_CORE, + SEXP_OPCODE, + SEXP_LAMBDA, + SEXP_CND, + SEXP_REF, + SEXP_SET, + SEXP_SEQ, + SEXP_LIT, + SEXP_STACK, + SEXP_CONTEXT, + SEXP_NUM_TYPES, +}; + +typedef unsigned long sexp_uint_t; +typedef long sexp_sint_t; +typedef unsigned char sexp_tag_t; +typedef struct sexp_struct *sexp; + +struct sexp_gc_var_t { + sexp *var; + char *name; + struct sexp_gc_var_t *next; +}; + +struct sexp_struct { + sexp_tag_t tag; + char immutablep; + char gc_mark; + union { + /* basic types */ + double flonum; + struct { + sexp_tag_t tag; + short field_base, field_len_base, field_len_off, field_len_scale; + short size_base, size_off, size_scale; + char *name; + } type; + struct { + sexp car, cdr; + sexp source; + } pair; + struct { + sexp_uint_t length; + sexp data[]; + } vector; + struct { + sexp_uint_t length; + char data[]; + } string; + struct { + sexp string; + } symbol; + struct { + FILE *stream; + char *buf; + sexp_uint_t offset, line, size, openp, sourcep; + sexp name; + sexp cookie; + } port; + struct { + sexp kind, message, irritants, procedure, source; + } exception; + struct { + char sign; + sexp_uint_t length; + sexp_uint_t *data; + } bignum; + /* runtime types */ + struct { + char flags; + sexp parent, lambda, bindings; + } env; + struct { + sexp_uint_t length; + sexp name, literals; + unsigned char data[]; + } bytecode; + struct { + char flags; + unsigned short num_args; + sexp bc, vars; + } procedure; + struct { + sexp proc, env; + } macro; + struct { + sexp env, free_vars, expr; + } synclo; + struct { + unsigned char op_class, code, num_args, flags, + arg1_type, arg2_type, inverse; + char *name; + sexp data, dflt, proc; + } opcode; + struct { + char code; + char *name; + } core; + /* ast types */ + struct { + sexp name, params, locals, defs, flags, fv, sv, body; + } lambda; + struct { + sexp test, pass, fail; + } cnd; + struct { + sexp var, value; + } set; + struct { + sexp name, cell; + } ref; + struct { + sexp ls; + } seq; + struct { + sexp value; + } lit; + /* compiler state */ + struct { + sexp_uint_t length, top; + sexp data[]; + } stack; + struct { + struct sexp_gc_var_t *saves; + sexp_uint_t pos, depth, tailp, tracep; + sexp bc, lambda, stack, env, fv, parent; + } context; + } value; +}; + +#define SEXP_MAKE_IMMEDIATE(n) ((sexp) ((n<value.x)) + +#define sexp_offsetof(type, f) (offsetof(struct sexp_struct, value.type.f)) + +#define sexp_alloc_type(ctx, type, tag) sexp_alloc_tagged(ctx, sexp_sizeof(type), tag) + +/***************************** predicates *****************************/ + +#define sexp_truep(x) ((x) != SEXP_FALSE) +#define sexp_not(x) ((x) == SEXP_FALSE) + +#define sexp_nullp(x) ((x) == SEXP_NULL) +#define sexp_pointerp(x) (((sexp_uint_t)(x) & SEXP_FIXNUM_MASK) == SEXP_POINTER_TAG) +#define sexp_integerp(x) (((sexp_uint_t)(x) & SEXP_FIXNUM_MASK) == SEXP_FIXNUM_TAG) +#define sexp_isymbolp(x) (((sexp_uint_t)(x) & SEXP_IMMEDIATE_MASK) == SEXP_ISYMBOL_TAG) +#define sexp_charp(x) (((sexp_uint_t)(x) & SEXP_EXTENDED_MASK) == SEXP_CHAR_TAG) +#define sexp_booleanp(x) (((x) == SEXP_TRUE) || ((x) == SEXP_FALSE)) + +#define sexp_pointer_tag(x) ((x)->tag) +#define sexp_gc_mark(x) ((x)->gc_mark) + +#define sexp_check_tag(x,t) (sexp_pointerp(x) && (sexp_pointer_tag(x) == (t))) + +#if USE_IMMEDIATE_FLONUMS +union sexp_flonum_conv { + float flonum; + sexp_uint_t bits; +}; +#define sexp_flonump(x) (((sexp_uint_t)(x) & SEXP_IMMEDIATE_MASK) == SEXP_IFLONUM_TAG) +#define sexp_make_flonum(ctx, x) ((sexp) ((((union sexp_flonum_conv)((float)(x))).bits & ~SEXP_IMMEDIATE_MASK) + SEXP_IFLONUM_TAG)) +#define sexp_flonum_value(x) (((union sexp_flonum_conv)(((sexp_uint_t)(x)) & ~SEXP_IMMEDIATE_MASK)).flonum) +#else +#define sexp_flonump(x) (sexp_check_tag(x, SEXP_FLONUM)) +#define sexp_flonum_value(f) ((f)->value.flonum) +sexp sexp_make_flonum(sexp ctx, double f); +#endif + +#define sexp_typep(x) (sexp_check_tag(x, SEXP_TYPE)) +#define sexp_pairp(x) (sexp_check_tag(x, SEXP_PAIR)) +#define sexp_stringp(x) (sexp_check_tag(x, SEXP_STRING)) +#define sexp_lsymbolp(x) (sexp_check_tag(x, SEXP_SYMBOL)) +#define sexp_vectorp(x) (sexp_check_tag(x, SEXP_VECTOR)) +#define sexp_iportp(x) (sexp_check_tag(x, SEXP_IPORT)) +#define sexp_oportp(x) (sexp_check_tag(x, SEXP_OPORT)) +#define sexp_exceptionp(x) (sexp_check_tag(x, SEXP_EXCEPTION)) +#define sexp_procedurep(x) (sexp_check_tag(x, SEXP_PROCEDURE)) +#define sexp_envp(x) (sexp_check_tag(x, SEXP_ENV)) +#define sexp_bytecodep(x) (sexp_check_tag(x, SEXP_BYTECODE)) +#define sexp_corep(x) (sexp_check_tag(x, SEXP_CORE)) +#define sexp_opcodep(x) (sexp_check_tag(x, SEXP_OPCODE)) +#define sexp_macrop(x) (sexp_check_tag(x, SEXP_MACRO)) +#define sexp_synclop(x) (sexp_check_tag(x, SEXP_SYNCLO)) +#define sexp_lambdap(x) (sexp_check_tag(x, SEXP_LAMBDA)) +#define sexp_cndp(x) (sexp_check_tag(x, SEXP_CND)) +#define sexp_refp(x) (sexp_check_tag(x, SEXP_REF)) +#define sexp_setp(x) (sexp_check_tag(x, SEXP_SET)) +#define sexp_seqp(x) (sexp_check_tag(x, SEXP_SEQ)) +#define sexp_litp(x) (sexp_check_tag(x, SEXP_LIT)) +#define sexp_contextp(x) (sexp_check_tag(x, SEXP_CONTEXT)) +#define sexp_symbolp(x) (sexp_isymbolp(x) || sexp_lsymbolp(x)) + +#define sexp_idp(x) \ + (sexp_symbolp(x) || (sexp_synclop(x) && sexp_symbolp(sexp_synclo_expr(x)))) + +#define sexp_portp(x) (sexp_iportp(x) || sexp_oportp(x)) + +/***************************** constructors ****************************/ + +#define sexp_make_boolean(x) ((x) ? SEXP_TRUE : SEXP_FALSE) +#define sexp_unbox_boolean(x) (((x) == SEXP_FALSE) ? 0 : 1) + +#define sexp_make_integer(n) ((sexp) ((((sexp_sint_t)(n))<>SEXP_FIXNUM_BITS) + +#define sexp_make_character(n) ((sexp) ((((sexp_sint_t)(n))<>SEXP_EXTENDED_BITS)) + +#if USE_FLONUMS +#define sexp_integer_to_flonum(ctx, x) (sexp_make_flonum(ctx, sexp_unbox_integer(x))) +#else +#define sexp_integer_to_flonum(ctx, x) (x) +#endif + +/*************************** field accessors **************************/ + +#define sexp_vector_length(x) ((x)->value.vector.length) +#define sexp_vector_data(x) ((x)->value.vector.data) + +#define sexp_vector_ref(x,i) (sexp_vector_data(x)[sexp_unbox_integer(i)]) +#define sexp_vector_set(x,i,v) (sexp_vector_data(x)[sexp_unbox_integer(i)]=(v)) + +#define sexp_procedure_num_args(x) ((x)->value.procedure.num_args) +#define sexp_procedure_flags(x) ((x)->value.procedure.flags) +#define sexp_procedure_variadic_p(x) (sexp_unbox_integer(sexp_procedure_flags(x)) & 1) +#define sexp_procedure_code(x) ((x)->value.procedure.bc) +#define sexp_procedure_vars(x) ((x)->value.procedure.vars) + +#define sexp_string_length(x) ((x)->value.string.length) +#define sexp_string_data(x) ((x)->value.string.data) + +#define sexp_string_ref(x, i) (sexp_make_character(sexp_string_data(x)[sexp_unbox_integer(i)])) +#define sexp_string_set(x, i, v) (sexp_string_data(x)[sexp_unbox_integer(i)] = sexp_unbox_character(v)) + +#define sexp_symbol_string(x) ((x)->value.symbol.string) + +#define sexp_port_stream(p) ((p)->value.port.stream) +#define sexp_port_name(p) ((p)->value.port.name) +#define sexp_port_line(p) ((p)->value.port.line) +#define sexp_port_openp(p) ((p)->value.port.openp) +#define sexp_port_sourcep(p) ((p)->value.port.sourcep) +#define sexp_port_cookie(p) ((p)->value.port.cookie) +#define sexp_port_buf(p) ((p)->value.port.buf) +#define sexp_port_size(p) ((p)->value.port.size) +#define sexp_port_offset(p) ((p)->value.port.offset) + +#define sexp_exception_kind(p) ((p)->value.exception.kind) +#define sexp_exception_message(p) ((p)->value.exception.message) +#define sexp_exception_irritants(p) ((p)->value.exception.irritants) +#define sexp_exception_procedure(p) ((p)->value.exception.procedure) +#define sexp_exception_source(p) ((p)->value.exception.source) + +#define sexp_bytecode_length(x) ((x)->value.bytecode.length) +#define sexp_bytecode_name(x) ((x)->value.bytecode.name) +#define sexp_bytecode_literals(x) ((x)->value.bytecode.literals) +#define sexp_bytecode_data(x) ((x)->value.bytecode.data) + +#define sexp_env_flags(x) ((x)->value.env.flags) +#define sexp_env_parent(x) ((x)->value.env.parent) +#define sexp_env_bindings(x) ((x)->value.env.bindings) +#define sexp_env_local_p(x) (sexp_env_parent(x)) +#define sexp_env_global_p(x) (! sexp_env_local_p(x)) +#define sexp_env_lambda(x) ((x)->value.env.lambda) + +#define sexp_macro_proc(x) ((x)->value.macro.proc) +#define sexp_macro_env(x) ((x)->value.macro.env) + +#define sexp_synclo_env(x) ((x)->value.synclo.env) +#define sexp_synclo_free_vars(x) ((x)->value.synclo.free_vars) +#define sexp_synclo_expr(x) ((x)->value.synclo.expr) + +#define sexp_core_code(x) ((x)->value.core.code) +#define sexp_core_name(x) ((x)->value.core.name) + +#define sexp_opcode_class(x) ((x)->value.opcode.op_class) +#define sexp_opcode_code(x) ((x)->value.opcode.code) +#define sexp_opcode_num_args(x) ((x)->value.opcode.num_args) +#define sexp_opcode_flags(x) ((x)->value.opcode.flags) +#define sexp_opcode_arg1_type(x) ((x)->value.opcode.arg1_type) +#define sexp_opcode_arg2_type(x) ((x)->value.opcode.arg2_type) +#define sexp_opcode_inverse(x) ((x)->value.opcode.inverse) +#define sexp_opcode_name(x) ((x)->value.opcode.name) +#define sexp_opcode_default(x) ((x)->value.opcode.dflt) +#define sexp_opcode_data(x) ((x)->value.opcode.data) +#define sexp_opcode_proc(x) ((x)->value.opcode.proc) + +#define sexp_opcode_variadic_p(x) (sexp_opcode_flags(x) & 1) +#define sexp_opcode_opt_param_p(x) (sexp_opcode_flags(x) & 2) + +#define sexp_lambda_name(x) ((x)->value.lambda.name) +#define sexp_lambda_params(x) ((x)->value.lambda.params) +#define sexp_lambda_locals(x) ((x)->value.lambda.locals) +#define sexp_lambda_defs(x) ((x)->value.lambda.defs) +#define sexp_lambda_flags(x) ((x)->value.lambda.flags) +#define sexp_lambda_body(x) ((x)->value.lambda.body) +#define sexp_lambda_fv(x) ((x)->value.lambda.fv) +#define sexp_lambda_sv(x) ((x)->value.lambda.sv) + +#define sexp_cnd_test(x) ((x)->value.cnd.test) +#define sexp_cnd_pass(x) ((x)->value.cnd.pass) +#define sexp_cnd_fail(x) ((x)->value.cnd.fail) + +#define sexp_set_var(x) ((x)->value.set.var) +#define sexp_set_value(x) ((x)->value.set.value) + +#define sexp_ref_name(x) ((x)->value.ref.name) +#define sexp_ref_cell(x) ((x)->value.ref.cell) +#define sexp_ref_loc(x) (sexp_cdr(sexp_ref_cell(x))) + +#define sexp_seq_ls(x) ((x)->value.seq.ls) + +#define sexp_lit_value(x) ((x)->value.lit.value) + +#define sexp_stack_length(x) ((x)->value.stack.length) +#define sexp_stack_top(x) ((x)->value.stack.top) +#define sexp_stack_data(x) ((x)->value.stack.data) + +#define sexp_context_heap(x) ((x)->value.context.heap) +#define sexp_context_symbols(x) ((x)->value.context.symbols) +#define sexp_context_env(x) ((x)->value.context.env) +#define sexp_context_stack(x) ((x)->value.context.stack) +#define sexp_context_depth(x) ((x)->value.context.depth) +#define sexp_context_bc(x) ((x)->value.context.bc) +#define sexp_context_fv(x) ((x)->value.context.fv) +#define sexp_context_pos(x) ((x)->value.context.pos) +#define sexp_context_lambda(x) ((x)->value.context.lambda) +#define sexp_context_parent(x) ((x)->value.context.parent) +#define sexp_context_saves(x) ((x)->value.context.saves) +#define sexp_context_tailp(x) ((x)->value.context.tailp) +#define sexp_context_tracep(x) ((x)->value.context.tailp) + +#define sexp_context_top(x) (sexp_stack_top(sexp_context_stack(x))) + +#define sexp_type_tag(x) ((x)->value.type.tag) +#define sexp_type_field_base(x) ((x)->value.type.field_base) +#define sexp_type_field_len_base(x) ((x)->value.type.field_len_base) +#define sexp_type_field_len_off(x) ((x)->value.type.field_len_off) +#define sexp_type_field_len_scale(x) ((x)->value.type.field_len_scale) +#define sexp_type_size_base(x) ((x)->value.type.size_base) +#define sexp_type_size_off(x) ((x)->value.type.size_off) +#define sexp_type_size_scale(x) ((x)->value.type.size_scale) +#define sexp_type_name(x) ((x)->value.type.name) + +/****************************** arithmetic ****************************/ + +#define sexp_fx_add(a, b) ((sexp)(((sexp_sint_t)a)+((sexp_sint_t)b)-SEXP_FIXNUM_TAG)) +#define sexp_fx_sub(a, b) ((sexp)(((sexp_sint_t)a)-((sexp_sint_t)b)+SEXP_FIXNUM_TAG)) +#define sexp_fx_mul(a, b) ((sexp)((((((sexp_sint_t)a)-SEXP_FIXNUM_TAG)*(((sexp_sint_t)b)>>SEXP_FIXNUM_BITS))+SEXP_FIXNUM_TAG))) +#define sexp_fx_div(a, b) (sexp_make_integer(sexp_unbox_integer(a) / sexp_unbox_integer(b))) +#define sexp_fx_rem(a, b) (sexp_make_integer(sexp_unbox_integer(a) % sexp_unbox_integer(b))) +#define sexp_fx_sign(a) (-((sexp_sint_t)(a) < 0)) /* -1 or 0 */ + +#define sexp_fp_add(x,a,b) (sexp_make_flonum(x, sexp_flonum_value(a) + sexp_flonum_value(b))) +#define sexp_fp_sub(x,a,b) (sexp_make_flonum(x, sexp_flonum_value(a) - sexp_flonum_value(b))) +#define sexp_fp_mul(x,a,b) (sexp_make_flonum(x, sexp_flonum_value(a) * sexp_flonum_value(b))) +#define sexp_fp_div(x,a,b) (sexp_make_flonum(x, sexp_flonum_value(a) / sexp_flonum_value(b))) + +/****************************** utilities *****************************/ + +#define sexp_list1(x,a) sexp_cons((x), (a), SEXP_NULL) + +#define sexp_push(ctx, ls, x) ((ls) = sexp_cons((ctx), (x), (ls))) +#define sexp_insert(ctx, ls, x) ((sexp_memq(NULL, (x), (ls)) != SEXP_FALSE) ? (ls) : sexp_push((ctx), (ls), (x))) + +#define sexp_pair_source(x) ((x)->value.pair.source) + +#define sexp_car(x) ((x)->value.pair.car) +#define sexp_cdr(x) ((x)->value.pair.cdr) + +#define sexp_caar(x) (sexp_car(sexp_car(x))) +#define sexp_cadr(x) (sexp_car(sexp_cdr(x))) +#define sexp_cdar(x) (sexp_cdr(sexp_car(x))) +#define sexp_cddr(x) (sexp_cdr(sexp_cdr(x))) +#define sexp_caaar(x) (sexp_car(sexp_caar(x))) +#define sexp_caadr(x) (sexp_car(sexp_cadr(x))) +#define sexp_cadar(x) (sexp_car(sexp_cdar(x))) +#define sexp_caddr(x) (sexp_car(sexp_cddr(x))) +#define sexp_cdaar(x) (sexp_cdr(sexp_caar(x))) +#define sexp_cdadr(x) (sexp_cdr(sexp_cadr(x))) +#define sexp_cddar(x) (sexp_cdr(sexp_cdar(x))) +#define sexp_cdddr(x) (sexp_cdr(sexp_cddr(x))) +#define sexp_cadddr(x) (sexp_cadr(sexp_cddr(x))) /* just these two */ +#define sexp_cddddr(x) (sexp_cddr(sexp_cddr(x))) + +/***************************** general API ****************************/ + +#if USE_STRING_STREAMS + +#define sexp_read_char(x, p) (getc(sexp_port_stream(p))) +#define sexp_push_char(x, c, p) (ungetc(c, sexp_port_stream(p))) +#define sexp_write_char(x, c, p) (putc(c, sexp_port_stream(p))) +#define sexp_write_string(x, s, p) (fputs(s, sexp_port_stream(p))) +#define sexp_printf(x, p, ...) (fprintf(sexp_port_stream(p), __VA_ARGS__)) +#define sexp_flush(x, p) (fflush(sexp_port_stream(p))) + +#else + +#define sexp_read_char(x, p) (sexp_port_buf(p) ? ((sexp_port_offset(p) < sexp_port_size(p)) ? sexp_port_buf(p)[sexp_port_offset(p)++] : sexp_buffered_read_char(x, p)) : getc(sexp_port_stream(p))) +#define sexp_push_char(x, c, p) (sexp_port_buf(p) ? (sexp_port_buf(p)[--sexp_port_offset(p)] = ((char)(c))) : ungetc(c, sexp_port_stream(p))) +#define sexp_write_char(x, c, p) (sexp_port_buf(p) ? ((sexp_port_offset(p) < sexp_port_size(p)) ? ((((sexp_port_buf(p))[sexp_port_offset(p)++]) = (char)(c)), SEXP_VOID) : sexp_buffered_write_char(x, c, p)) : (putc(c, sexp_port_stream(p)), SEXP_VOID)) +#define sexp_write_string(x, s, p) (sexp_port_buf(p) ? sexp_buffered_write_string(x, s, p) : (fputs(s, sexp_port_stream(p)), SEXP_VOID)) +#define sexp_flush(x, p) (sexp_port_buf(p) ? sexp_buffered_flush(x, p) : (fflush(sexp_port_stream(p)), SEXP_VOID)) + +int sexp_buffered_read_char (sexp ctx, sexp p); +sexp sexp_buffered_write_char (sexp ctx, int c, sexp p); +sexp sexp_buffered_write_string_n (sexp ctx, char *str, sexp_uint_t len, sexp p); +sexp sexp_buffered_write_string (sexp ctx, char *str, sexp p); +sexp sexp_buffered_flush (sexp ctx, sexp p); + +#endif + +#define sexp_newline(ctx, p) sexp_write_char(ctx, '\n', (p)) + +sexp sexp_alloc_tagged(sexp ctx, size_t size, sexp_uint_t tag); +sexp sexp_cons(sexp ctx, sexp head, sexp tail); +sexp sexp_list2(sexp ctx, sexp a, sexp b); +sexp sexp_equalp (sexp ctx, sexp a, sexp b); +sexp sexp_listp(sexp ctx, sexp obj); +sexp sexp_reverse(sexp ctx, sexp ls); +sexp sexp_nreverse(sexp ctx, sexp ls); +sexp sexp_append2(sexp ctx, sexp a, sexp b); +sexp sexp_memq(sexp ctx, sexp x, sexp ls); +sexp sexp_assq(sexp ctx, sexp x, sexp ls); +sexp sexp_length(sexp ctx, sexp ls); +sexp sexp_c_string(sexp ctx, char *str, sexp_sint_t slen); +sexp sexp_make_string(sexp ctx, sexp len, sexp ch); +sexp sexp_substring (sexp ctx, sexp str, sexp start, sexp end); +sexp sexp_string_concatenate (sexp ctx, sexp str_ls); +sexp sexp_intern(sexp ctx, char *str); +sexp sexp_string_to_symbol(sexp ctx, sexp str); +sexp sexp_make_vector(sexp ctx, sexp len, sexp dflt); +sexp sexp_list_to_vector(sexp ctx, sexp ls); +void sexp_write(sexp ctx, sexp obj, sexp out); +sexp sexp_read_string(sexp ctx, sexp in); +sexp sexp_read_symbol(sexp ctx, sexp in, int init, int internp); +sexp sexp_read_number(sexp ctx, sexp in, int base); +sexp sexp_read_raw(sexp ctx, sexp in); +sexp sexp_read(sexp ctx, sexp in); +sexp sexp_read_from_string(sexp ctx, char *str); +sexp sexp_make_input_port(sexp ctx, FILE* in, sexp name); +sexp sexp_make_output_port(sexp ctx, FILE* out, sexp name); +sexp sexp_make_input_string_port(sexp ctx, sexp str); +sexp sexp_make_output_string_port(sexp ctx); +sexp sexp_get_output_string(sexp ctx, sexp port); +sexp sexp_make_exception(sexp ctx, sexp kind, sexp message, sexp irritants, sexp procedure, sexp source); +sexp sexp_user_exception (sexp ctx, sexp self, char *message, sexp obj); +sexp sexp_type_exception (sexp ctx, char *message, sexp obj); +sexp sexp_range_exception (sexp ctx, sexp obj, sexp start, sexp end); +sexp sexp_print_exception(sexp ctx, sexp exn, sexp out); +void sexp_init(); + +#endif /* ! SEXP_H */ + diff --git a/init.scm b/init.scm new file mode 100644 index 00000000..08d321c1 --- /dev/null +++ b/init.scm @@ -0,0 +1,713 @@ + +;; provide c[ad]{2,4}r + +(define (caar x) (car (car x))) +(define (cadr x) (car (cdr x))) +(define (cdar x) (cdr (car x))) +(define (cddr x) (cdr (cdr x))) +(define (caaar x) (car (car (car x)))) +(define (caadr x) (car (car (cdr x)))) +(define (cadar x) (car (cdr (car x)))) +(define (caddr x) (car (cdr (cdr x)))) +(define (cdaar x) (cdr (car (car x)))) +(define (cdadr x) (cdr (car (cdr x)))) +(define (cddar x) (cdr (cdr (car x)))) +(define (cdddr x) (cdr (cdr (cdr x)))) +(define (caaaar x) (car (car (car (car x))))) +(define (caaadr x) (car (car (car (cdr x))))) +(define (caadar x) (car (car (cdr (car x))))) +(define (caaddr x) (car (car (cdr (cdr x))))) +(define (cadaar x) (car (cdr (car (car x))))) +(define (cadadr x) (car (cdr (car (cdr x))))) +(define (caddar x) (car (cdr (cdr (car x))))) +(define (cadddr x) (car (cdr (cdr (cdr x))))) +(define (cdaaar x) (cdr (car (car (car x))))) +(define (cdaadr x) (cdr (car (car (cdr x))))) +(define (cdadar x) (cdr (car (cdr (car x))))) +(define (cdaddr x) (cdr (car (cdr (cdr x))))) +(define (cddaar x) (cdr (cdr (car (car x))))) +(define (cddadr x) (cdr (cdr (car (cdr x))))) +(define (cdddar x) (cdr (cdr (cdr (car x))))) +(define (cddddr x) (cdr (cdr (cdr (cdr x))))) + +;; basic utils + +(define (procedure? x) (if (closure? x) #t (opcode? x))) + +(define (list . args) args) + +(define (list-tail ls k) + (if (eq? k 0) + ls + (list-tail (cdr ls) (- k 1)))) + +(define (list-ref ls k) (car (list-tail ls k))) + +(define (append-helper ls res) + (if (null? ls) + res + (append-helper (cdr ls) (append2 (car ls) res)))) + +(define (append . o) + (if (null? o) + '() + ((lambda (lol) + (append-helper (cdr lol) (car lol))) + (reverse o)))) + +(define (apply proc . args) + (if (null? args) + (proc) + ((lambda (lol) + (apply1 proc (append2 (reverse (cdr lol)) (car lol)))) + (reverse args)))) + +;; map with a fast-path for single lists + +(define (map proc ls . lol) + (define (map1 proc ls res) + (if (pair? ls) + (map1 proc (cdr ls) (cons (proc (car ls)) res)) + (reverse res))) + (define (mapn proc lol res) + (if (null? (car lol)) + (reverse res) + (mapn proc + (map1 cdr lol '()) + (cons (apply1 proc (map1 car lol '())) res)))) + (if (null? lol) + (map1 proc ls '()) + (mapn proc (cons ls lol) '()))) + +(define for-each map) + +(define (any pred ls) + (if (pair? ls) (if (pred (car ls)) #t (any pred (cdr ls))) #f)) + +;; syntax + +(define sc-macro-transformer + (lambda (f) + (lambda (expr use-env mac-env) + (make-syntactic-closure mac-env '() (f expr use-env))))) + +(define rsc-macro-transformer + (lambda (f) + (lambda (expr use-env mac-env) + (make-syntactic-closure use-env '() (f expr mac-env))))) + +(define er-macro-transformer + (lambda (f) + (lambda (expr use-env mac-env) + ((lambda (rename compare) (f expr rename compare)) + ((lambda (renames) + (lambda (identifier) + ((lambda (cell) + (if cell + (cdr cell) + ((lambda (name) + (set! renames (cons (cons identifier name) renames)) + name) + (make-syntactic-closure mac-env '() identifier)))) + (assq identifier renames)))) + '()) + (lambda (x y) (identifier=? use-env x use-env y)))))) + +(define-syntax cond + (er-macro-transformer + (lambda (expr rename compare) + (if (null? (cdr expr)) + #f + ((lambda (cl) + (if (compare 'else (car cl)) + (cons (rename 'begin) (cdr cl)) + (if (if (null? (cdr cl)) #t (compare '=> (cadr cl))) + (list (list (rename 'lambda) (list (rename 'tmp)) + (list (rename 'if) (rename 'tmp) + (if (null? (cdr cl)) + (rename 'tmp) + (list (caddr cl) (rename 'tmp))) + (cons (rename 'cond) (cddr expr)))) + (car cl)) + (list (rename 'if) + (car cl) + (cons (rename 'begin) (cdr cl)) + (cons (rename 'cond) (cddr expr)))))) + (cadr expr)))))) + +(define-syntax or + (er-macro-transformer + (lambda (expr rename compare) + (cond ((null? (cdr expr)) #f) + ((null? (cddr expr)) (cadr expr)) + (else + (list (rename 'let) (list (list (rename 'tmp) (cadr expr))) + (list (rename 'if) (rename 'tmp) + (rename 'tmp) + (cons (rename 'or) (cddr expr))))))))) + +(define-syntax and + (er-macro-transformer + (lambda (expr rename compare) + (cond ((null? (cdr expr))) + ((null? (cddr expr)) (cadr expr)) + (else (list (rename 'if) (cadr expr) + (cons (rename 'and) (cddr expr)) + #f)))))) + +(define-syntax quasiquote + (er-macro-transformer + (lambda (expr rename compare) + (define (qq x d) + (cond + ((pair? x) + (cond + ((eq? 'unquote (car x)) + (if (<= d 0) + (cadr x) + (list (rename 'list) (list (rename 'quote) 'unquote) + (qq (cadr x) (- d 1))))) + ((eq? 'unquote-splicing (car x)) + (if (<= d 0) + (list (rename 'cons) (qq (car x) d) (qq (cdr x) d)) + (list (rename 'list) (list (rename 'quote) 'unquote-splicing) + (qq (cadr x) (- d 1))))) + ((eq? 'quasiquote (car x)) + (list (rename 'list) (list (rename 'quote) 'quasiquote) + (qq (cadr x) (+ d 1)))) + ((and (<= d 0) (pair? (car x)) (eq? 'unquote-splicing (caar x))) + (if (null? (cdr x)) + (cadar x) + (list (rename 'append) (cadar x) (qq (cdr x) d)))) + (else + (list (rename 'cons) (qq (car x) d) (qq (cdr x) d))))) + ((vector? x) (list (rename 'list->vector) (qq (vector->list x) d))) + ((symbol? x) (list (rename 'quote) x)) + (else x))) + (qq (cadr expr) 0)))) + +(define-syntax letrec + (er-macro-transformer + (lambda (expr rename compare) + ((lambda (defs) + `((,(rename 'lambda) () ,@defs ,@(cddr expr)))) + (map (lambda (x) (cons (rename 'define) x)) (cadr expr)))))) + +(define-syntax let + (er-macro-transformer + (lambda (expr rename compare) + (if (identifier? (cadr expr)) + `(,(rename 'letrec) ((,(cadr expr) + (,(rename 'lambda) ,(map car (caddr expr)) + ,@(cdddr expr)))) + ,(cons (cadr expr) (map cadr (caddr expr)))) + `((,(rename 'lambda) ,(map car (cadr expr)) ,@(cddr expr)) + ,@(map cadr (cadr expr))))))) + +(define-syntax let* + (er-macro-transformer + (lambda (expr rename compare) + (if (null? (cadr expr)) + `(,(rename 'begin) ,@(cddr expr)) + `(,(rename 'let) (,(caadr expr)) + (,(rename 'let*) ,(cdadr expr) ,@(cddr expr))))))) + +(define-syntax case + (er-macro-transformer + (lambda (expr rename compare) + (define (clause ls) + (cond + ((null? ls) #f) + ((compare 'else (caar ls)) + `(,(rename 'begin) ,@(cdar ls))) + (else + (if (and (pair? (caar ls)) (null? (cdaar ls))) + `(,(rename 'if) (,(rename 'eqv?) ,(rename 'tmp) ',(caaar ls)) + (,(rename 'begin) ,@(cdar ls)) + ,(clause (cdr ls))) + `(,(rename 'if) (,(rename 'memv) ,(rename 'tmp) ',(caar ls)) + (,(rename 'begin) ,@(cdar ls)) + ,(clause (cdr ls))))))) + `(let ((,(rename 'tmp) ,(cadr expr))) + ,(clause (cddr expr)))))) + +(define-syntax do + (er-macro-transformer + (lambda (expr rename compare) + (let* ((body + `(,(rename 'begin) + ,@(cdddr expr) + (,(rename 'lp) + ,@(map (lambda (x) (if (pair? (cddr x)) (caddr x) (car x))) + (cadr expr))))) + (check (caddr expr)) + (wrap + (if (null? (cdr check)) + `(,(rename 'let) ((,(rename 'tmp) ,(car check))) + (,(rename 'if) ,(rename 'tmp) + ,(rename 'tmp) + ,body)) + `(,(rename 'if) ,(car check) + (,(rename 'begin) ,@(cdr check)) + ,body)))) + `(,(rename 'let) ,(rename 'lp) + ,(map (lambda (x) (list (car x) (cadr x))) (cadr expr)) + ,wrap))))) + +(define-syntax delay + (er-macro-transformer + (lambda (expr rename compare) + `(,(rename 'make-promise) (,(rename 'lambda) () ,(cadr expr)))))) + +(define (make-promise thunk) + (lambda () + (let ((computed? #f) (result #f)) + (if (not computed?) + (begin + (set! result (thunk)) + (set! computed? #t))) + result))) + +(define (force x) (if (procedure? x) (x) x)) + +(define (error msg . args) + (raise (make-exception 'user msg args #f #f #f))) + +(define (with-exception-handler handler thunk) + (let ((orig-handler (current-exception-handler))) + (current-exception-handler handler) + (let ((res (thunk))) + (current-exception-handler orig-handler) + res))) + +;; booleans + +(define (not x) (if x #f #t)) +(define (boolean? x) (if (eq? x #t) #t (eq? x #f))) + +;; char utils + +(define (char-alphabetic? ch) (<= 65 (char->integer (char-upcase ch)) 90)) +(define (char-numeric? ch) (<= 48 (char->integer ch) 57)) +(define (char-whitespace? ch) + (if (eq? ch #\space) + #t + (if (eq? ch #\tab) #t (if (eq? ch #\newline) #t (eq? ch #\return))))) +(define (char-upper-case? ch) (<= 65 (char->integer ch) 90)) +(define (char-lower-case? ch) (<= 97 (char->integer ch) 122)) + +(define (char=? a b) (= (char->integer a) (char->integer b))) +(define (charinteger a) (char->integer b))) +(define (char>? a b) (> (char->integer a) (char->integer b))) +(define (char<=? a b) (<= (char->integer a) (char->integer b))) +(define (char>=? a b) (>= (char->integer a) (char->integer b))) + +(define (char-ci=? a b) + (= (char->integer (char-downcase a)) (char->integer (char-downcase b)))) +(define (char-ciinteger (char-downcase a)) (char->integer (char-downcase b)))) +(define (char-ci>? a b) + (> (char->integer (char-downcase a)) (char->integer (char-downcase b)))) +(define (char-ci<=? a b) + (<= (char->integer (char-downcase a)) (char->integer (char-downcase b)))) +(define (char-ci>=? a b) + (>= (char->integer (char-downcase a)) (char->integer (char-downcase b)))) + +;; string utils + +(define (symbol->string sym) + (call-with-output-string (lambda (out) (write sym out)))) + +(define (list->string ls) + (let ((str (make-string (length ls) #\space))) + (let lp ((ls ls) (i 0)) + (if (pair? ls) + (begin + (string-set! str i (car ls)) + (lp (cdr ls) (+ i 1))))) + str)) + +(define (string->list str) + (let lp ((i (- (string-length str) 1)) (res '())) + (if (< i 0) res (lp (- i 1) (cons (string-ref str i) res))))) + +(define (string-fill! str ch) + (let lp ((i (- (string-length str) 1))) + (if (>= i 0) (begin (string-set! str i ch) (lp (- i 1)))))) + +(define (string . args) (list->string args)) +(define (string-append . args) (string-concatenate args)) +(define (string-copy s) (substring s 0 (string-length s))) + +(define (string=? s1 s2) (eq? (string-cmp s1 s2 #f) 0)) +(define (string? s1 s2) (> (string-cmp s1 s2 #f) 0)) +(define (string>=? s1 s2) (>= (string-cmp s1 s2 #f) 0)) + +(define (string-ci=? s1 s2) (eq? (string-cmp s1 s2 #t) 0)) +(define (string-ci? s1 s2) (> (string-cmp s1 s2 #t) 0)) +(define (string-ci>=? s1 s2) (>= (string-cmp s1 s2 #t) 0)) + +;; list utils + +(define (eqv? a b) (if (eq? a b) #t (and (flonum? a) (flonum? b) (= a b)))) + +(define (member obj ls) + (if (null? ls) + #f + (if (equal? obj (car ls)) + ls + (member obj (cdr ls))))) + +(define memv member) + +(define (assoc obj ls) + (if (null? ls) + #f + (if (equal? obj (caar ls)) + (car ls) + (assoc obj (cdr ls))))) + +(define assv assoc) + +;; math utils + +(define (number? x) (if (fixnum? x) #t (flonum? x))) +(define complex? number?) +(define rational? number?) +(define real? number?) +(define exact? fixnum?) +(define inexact? flonum?) +(define (integer? x) (if (fixnum? x) #t (and (flonum? x) (= x (truncate x))))) + +(define (zero? x) (= x 0)) +(define (positive? x) (> x 0)) +(define (negative? x) (< x 0)) +(define (even? n) (= (remainder n 2) 0)) +(define (odd? n) (= (remainder n 2) 1)) + +(define (abs x) (if (< x 0) (- x) x)) + +(define (modulo a b) + (let ((res (remainder a b))) + (if (< b 0) + (if (<= res 0) res (+ res b)) + (if (>= res 0) res (+ res b))))) + +(define (gcd a b) + (if (= b 0) + (abs a) + (gcd b (remainder a b)))) + +(define (lcm a b) + (abs (quotient (* a b) (gcd a b)))) + +(define (max x . rest) + (let lp ((hi x) (ls rest)) + (if (null? ls) + hi + (lp (if (> (car ls) hi) (car ls) hi) (cdr ls))))) + +(define (min x . rest) + (let lp ((lo x) (ls rest)) + (if (null? ls) + lo + (lp (if (< (car ls) lo) (car ls) lo) (cdr ls))))) + +(define (real-part z) z) +(define (imag-part z) 0.0) +(define magnitude abs) +(define (angle z) (if (< z 0) 3.141592653589793 0)) + +(define (atan x . o) (if (null? o) (atan1 x) (atan1 (/ x (car o))))) + +(define (digit-char n) (integer->char (+ n (char->integer #\0)))) +(define (digit-value ch) + (if (char-numeric? ch) + (- (char->integer ch) (char->integer #\0)) + (and (<= 65 (char->integer (char-upcase ch)) 70) + (- (char->integer (char-upcase ch)) 65)))) + +(define (number->string n . o) + (if (if (null? o) #t (eq? 10 (car o))) + (call-with-output-string (lambda (out) (write n out))) + (let lp ((n n) (d (car o)) (res '())) + (if (> n 0) + (lp (quotient n d) d (cons (digit-char (remainder n d)) res)) + (list->string res))))) + +(define (string->number str . o) + (let ((res + (if (if (null? o) #t (eq? 10 (car o))) + (call-with-input-string str (lambda (in) (read in))) + (let ((len (string-length str))) + (let lp ((i 0) (d (car o)) (acc 0)) + (if (>= i len) + acc + (let ((v (digit-value (string-ref str i)))) + (and v (lp (+ i 1) d (+ (* acc d) v)))))))))) + (and (number? res) res))) + +;; vector utils + +(define (list->vector ls) + (let ((vec (make-vector (length ls) #f))) + (let lp ((ls ls) (i 0)) + (if (pair? ls) + (begin + (vector-set! vec i (car ls)) + (lp (cdr ls) (+ i 1))))) + vec)) + +(define (vector->list vec) + (let lp ((i (- (vector-length vec) 1)) (res '())) + (if (< i 0) res (lp (- i 1) (cons (vector-ref vec i) res))))) + +(define (vector-fill! str ch) + (let lp ((i (- (vector-length str) 1))) + (if (>= i 0) (begin (vector-set! str i ch) (lp (- i 1)))))) + +(define (vector . args) (list->vector args)) + +;; I/O utils + +(define (char-ready? . o) + (not (eof-object? (peek-char (if (pair? o) (car o) (current-input-port)))))) + +(define (load file) (%load file (interaction-environment))) + +(define (call-with-input-string str proc) + (let* ((in (open-input-string str)) + (res (proc in))) + (close-input-port in) + res)) + +(define (call-with-output-string proc) + (let ((out (open-output-string))) + (proc out) + (let ((res (get-output-string out))) + (close-output-port out) + res))) + +(define (call-with-input-file file proc) + (let* ((in (open-input-file file)) + (res (proc in))) + (close-input-port in) + res)) + +(define (call-with-output-file file proc) + (let* ((out (open-output-file file)) + (res (proc out))) + (close-output-port out) + res)) + +(define (with-input-from-file file thunk) + (let ((old-in (current-input-port)) + (tmp-in (open-input-file file))) + (current-input-port tmp-in) + (let ((res (thunk))) + (current-input-port old-in) + res))) + +(define (with-output-to-file file thunk) + (let ((old-out (current-input-port)) + (tmp-out (open-output-file file))) + (current-input-port tmp-out) + (let ((res (thunk))) + (current-output-port old-out) + res))) + +;; values + +(define *values-tag* (list 'values)) + +(define (values . ls) + (if (and (pair? ls) (null? (cdr ls))) + (car ls) + (cons *values-tag* ls))) + +(define (call-with-values producer consumer) + (let ((res (producer))) + (if (and (pair? res) (eq? *values-tag* (car res))) + (apply consumer (cdr res)) + (consumer res)))) + +;; syntax-rules + +(define-syntax syntax-rules + (er-macro-transformer + (lambda (expr rename compare) + (let ((lits (cadr expr)) + (forms (cddr expr)) + (count 0) + (_er-macro-transformer (rename 'er-macro-transformer)) + (_lambda (rename 'lambda)) (_let (rename 'let)) + (_begin (rename 'begin)) (_if (rename 'if)) + (_and (rename 'and)) (_or (rename 'or)) + (_eq? (rename 'eq?)) (_equal? (rename 'equal?)) + (_car (rename 'car)) (_cdr (rename 'cdr)) + (_cons (rename 'cons)) (_pair? (rename 'pair?)) + (_null? (rename 'null?)) (_expr (rename 'expr)) + (_rename (rename 'rename)) (_compare (rename 'compare)) + (_quote (rename 'quote)) (_apply (rename 'apply)) + (_append (rename 'append)) (_map (rename 'map)) + (_vector? (rename 'vector?)) (_list? (rename 'list?)) + (_lp (rename 'lp)) (_reverse (rename 'reverse)) + (_vector->list (rename 'vector->list)) + (_list->vector (rename 'list->vector))) + (define (next-v) + (set! count (+ count 1)) + (rename (string->symbol (string-append "v." (number->string count))))) + (define (expand-pattern pat tmpl) + (let lp ((p (cdr pat)) + (x (list _cdr _expr)) + (dim 0) + (vars '()) + (k (lambda (vars) + (or (expand-template tmpl vars) + (list _begin #f))))) + (let ((v (next-v))) + (list + _let (list (list v x)) + (cond + ((identifier? p) + (if (any (lambda (l) (compare p l)) lits) + (list _and (list _compare v (list _quote p)) (k vars)) + (list _let (list (list p v)) (k (cons (cons p dim) vars))))) + ((ellipse? p) + (cond + ((not (null? (cddr p))) + (error "non-trailing ellipse")) + ((identifier? (car p)) + (list _and (list _list? v) + (list _let (list (list (car p) v)) + (k (cons (cons (car p) (+ 1 dim)) vars))))) + (else + (let* ((w (next-v)) + (new-vars (all-vars (car p) (+ dim 1))) + (ls-vars (map (lambda (x) + (rename + (string->symbol + (string-append + (symbol->string + (identifier->symbol (car x))) + "-ls")))) + new-vars)) + (once + (lp (car p) (list _car w) (+ dim 1) '() + (lambda (_) + (cons + _lp + (cons + (list _cdr w) + (map (lambda (x l) + (list _cons (car x) l)) + new-vars + ls-vars))))))) + (list + _let + _lp (cons (list w v) + (map (lambda (x) (list x '())) ls-vars)) + (list _if (list _null? w) + (list _let (map (lambda (x l) + (list (car x) (list _reverse l))) + new-vars + ls-vars) + (k (append new-vars vars))) + (list _and (list _pair? w) once))))))) + ((pair? p) + (list _and (list _pair? v) + (lp (car p) + (list _car v) + dim + vars + (lambda (vars) + (lp (cdr p) (list _cdr v) dim vars k))))) + ((vector? p) + (list _and + (list _vector? v) + (lp (vector->list p) (list _vector->list v) dim vars k))) + ((null? p) (list _and (list _null? v) (k vars))) + (else (list _and (list _equal? v p) (k vars)))))))) + (define (ellipse? x) + (and (pair? x) (pair? (cdr x)) (compare '... (cadr x)))) + (define (ellipse-depth x) + (if (ellipse? x) + (+ 1 (ellipse-depth (cdr x))) + 0)) + (define (ellipse-tail x) + (if (ellipse? x) + (ellipse-tail (cdr x)) + (cdr x))) + (define (all-vars x dim) + (let lp ((x x) (dim dim) (vars '())) + (cond ((identifier? x) (if (memq x (list _quote lits)) + vars + (cons (cons x dim) vars))) + ((ellipse? x) (lp (car x) (+ dim 1) vars)) + ((pair? x) (lp (car x) dim (lp (cdr x) dim vars))) + ((vector? x) (lp (vector->list x) dim vars)) + (else vars)))) + (define (free-vars x vars dim) + (let lp ((x x) (free '())) + (cond + ((identifier? x) + (if (and (not (memq x free)) + (cond ((assq x vars) => (lambda (cell) (>= (cdr cell) dim))) + (else #f))) + (cons x free) + free)) + ((pair? x) (lp (car x) (lp (cdr x) free))) + ((vector? x) (lp (vector->list x) free)) + (else free)))) + (define (expand-template tmpl vars) + (let lp ((t tmpl) (dim 0)) + (cond + ((identifier? t) + (cond + ((assq t vars) + => (lambda (cell) + (if (<= (cdr cell) dim) + t + (error "too few ...'s")))) + (else + (list _rename (list _quote t))))) + ((pair? t) + (if (ellipse? t) + (let* ((depth (ellipse-depth t)) + (ell-dim (+ dim depth)) + (ell-vars (free-vars (car t) vars ell-dim))) + (if (null? ell-vars) + (error "too many ...'s") + (let* ((once (lp (car t) ell-dim)) + (nest (if (and (null? (cdr ell-vars)) + (identifier? once) + (eq? once (car vars))) + once ;; shortcut + (cons _map + (cons (list _lambda ell-vars once) + ell-vars)))) + (many (do ((d depth (- d 1)) + (many nest + (list _apply _append many))) + ((= d 1) many)))) + (if (null? (ellipse-tail t)) + many ;; shortcut + (list _append many (lp (ellipse-tail t) dim)))))) + (list _cons (lp (car t) dim) (lp (cdr t) dim)))) + ((vector? t) (list _list->vector (lp (vector->list t) dim))) + ((null? t) (list _quote '())) + (else t)))) + (list + _er-macro-transformer + (list _lambda (list _expr _rename _compare) + (cons + _or + (append + (map + (lambda (clause) (expand-pattern (car clause) (cadr clause))) + forms) + (list (list 'error "no expansion")))))))))) diff --git a/main.c b/main.c new file mode 100644 index 00000000..b9f63700 --- /dev/null +++ b/main.c @@ -0,0 +1,152 @@ +/* main.c -- chibi-scheme command-line app */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#ifdef PLAN9 +#define file_exists_p(path, buf) (stat(path, buf, 128) >= 0) +#else +#include +#define file_exists_p(path, buf) (! stat(path, buf)) +#endif + +#include "chibi/eval.h" + +char *chibi_module_dir = NULL; + +sexp find_module_file (sexp ctx, char *file) { + sexp res; + int mlen, flen; + char *path; +#ifdef PLAN9 + unsigned char buf[128]; +#else + struct stat buf_str; + struct stat *buf = &buf_str; +#endif + + if (file_exists_p(file, buf)) + return sexp_c_string(ctx, file, -1); + if (! chibi_module_dir) { +#ifndef PLAN9 + chibi_module_dir = getenv("CHIBI_MODULE_DIR"); + if (! chibi_module_dir) +#endif + chibi_module_dir = sexp_module_dir; + } + mlen = strlen(chibi_module_dir); + flen = strlen(file); + path = (char*) malloc(mlen+flen+2); + memcpy(path, chibi_module_dir, mlen); + path[mlen] = '/'; + memcpy(path+mlen+1, file, flen); + path[mlen+flen+1] = '\0'; + if (file_exists_p(path, buf)) + res = sexp_c_string(ctx, path, mlen+flen+2); + else + res = SEXP_FALSE; + free(path); + return res; +} + +void repl (sexp ctx) { + sexp tmp, res, env, in, out, err; + sexp_gc_var(ctx, obj, s_obj); + sexp_gc_preserve(ctx, obj, s_obj); + env = sexp_context_env(ctx); + sexp_context_tracep(ctx) = 1; + in = sexp_eval_string(ctx, "(current-input-port)"); + out = sexp_eval_string(ctx, "(current-output-port)"); + err = sexp_eval_string(ctx, "(current-error-port)"); + sexp_port_sourcep(in) = 1; + while (1) { + sexp_write_string(ctx, "> ", out); + sexp_flush(ctx, out); + obj = sexp_read(ctx, in); + if (obj == SEXP_EOF) + break; + if (sexp_exceptionp(obj)) { + sexp_print_exception(ctx, obj, err); + } else { + tmp = sexp_env_bindings(env); + sexp_context_top(ctx) = 0; + res = sexp_eval(ctx, obj); +#if USE_WARN_UNDEFS + sexp_warn_undefs(ctx, sexp_env_bindings(env), tmp, err); +#endif + if (res != SEXP_VOID) { + sexp_write(ctx, res, out); + sexp_write_char(ctx, '\n', out); + } + } + } + sexp_gc_release(ctx, obj, s_obj); +} + +void run_main (int argc, char **argv) { + sexp env, out=NULL, res, ctx; + sexp_uint_t i, quit=0, init_loaded=0; + sexp_gc_var(ctx, str, s_str); + + ctx = sexp_make_context(NULL, NULL, NULL); + sexp_gc_preserve(ctx, str, s_str); + env = sexp_context_env(ctx); + out = sexp_eval_string(ctx, "(current-output-port)"); + + /* parse options */ + for (i=1; i < argc && argv[i][0] == '-'; i++) { + switch (argv[i][1]) { + case 'e': + case 'p': + if (! init_loaded++) + sexp_load(ctx, str=find_module_file(ctx, sexp_init_file), env); + res = sexp_read_from_string(ctx, argv[i+1]); + if (! sexp_exceptionp(res)) + res = sexp_eval(ctx, res); + if (sexp_exceptionp(res)) { + sexp_print_exception(ctx, res, out); + quit = 1; + break; + } else if (argv[i][1] == 'p') { + sexp_write(ctx, res, out); + sexp_write_char(ctx, '\n', out); + } + quit=1; + i++; + break; + case 'l': + if (! init_loaded++) + sexp_load(ctx, str=find_module_file(ctx, sexp_init_file), env); + sexp_load(ctx, str=find_module_file(ctx, argv[++i]), env); + break; + case 'q': + init_loaded = 1; + break; + case 'm': + chibi_module_dir = argv[++i]; + break; + default: + errx(1, "unknown option: %s", argv[i]); + } + } + + if (! quit) { + if (! init_loaded) + res = sexp_load(ctx, str=find_module_file(ctx, sexp_init_file), env); + if (! sexp_exceptionp(res)) { + if (i < argc) + for ( ; i < argc; i++) + sexp_load(ctx, str=sexp_c_string(ctx, argv[i], -1), env); + else + repl(ctx); + } + } + + sexp_gc_release(ctx, str, s_str); +} + +int main (int argc, char **argv) { + sexp_scheme_init(); + run_main(argc, argv); + return 0; +} + diff --git a/mkfile b/mkfile new file mode 100644 index 00000000..3caba3f9 --- /dev/null +++ b/mkfile @@ -0,0 +1,36 @@ + $target + +%.$O: %.i + $CC $CFLAGS -c -o $target $prereq + +all:V: $TARG + +include/chibi/install.h: mkfile + echo '#define sexp_module_dir "'$MODDIR'"' > include/chibi/install.h + +$TARG: $OFILES + $LD $LDFLAGS -o $target $prereq + +$BIN/%: % + cp $stem $target + +clean:V: + rm -f $IFILES $TARG *.[$OS] + +install:V: $BIN/$TARG + mkdir -p $MODDIR + cp init.scm $MODDIR/ diff --git a/opcodes.c b/opcodes.c new file mode 100644 index 00000000..52e75045 --- /dev/null +++ b/opcodes.c @@ -0,0 +1,129 @@ + +#define _OP(c,o,n,m,t,u,i,s,f,d) \ + {.tag=SEXP_OPCODE, \ + .value={.opcode={c, o, n, m, t, u, i, s, d, f, NULL}}} +#define _FN(o,n,m,t,u,s,f,d) _OP(OPC_FOREIGN, o, n, m, t, u, 0, s, f, (sexp)d) +#define _FN0(s, f, d) _FN(OP_FCALL0, 0, 0, 0, 0, s, f, d) +#define _FN1(t, s, f, d) _FN(OP_FCALL1, 1, 0, t, 0, s, f, d) +#define _FN2(t, u, s, f, d) _FN(OP_FCALL2, 2, 0, t, u, s, f, d) +#define _FN2OPT(t, u, s, f, d) _FN(OP_FCALL2, 1, 1, t, u, s, f, d) +#define _FN3(t, u, s, f, d) _FN(OP_FCALL3, 3, 0, t, u, s, f, d) +#define _FN4(t, u, s, f, d) _FN(OP_FCALL4, 4, 0, t, u, s, f, d) +#define _FN5(t, u, s, f, d) _FN(OP_FCALL5, 5, 0, t, u, s, f, d) +#define _FN6(t, u, s, f, d) _FN(OP_FCALL6, 6, 0, t, u, s, f, d) +#define _PARAM(n, a, t) _OP(OPC_PARAMETER, OP_NOOP, 0, 3, t, 0, 0, n, a, 0) + +static struct sexp_struct opcodes[] = { +_OP(OPC_ACCESSOR, OP_CAR, 1, 0, SEXP_PAIR, 0, 0, "car", 0, NULL), +_OP(OPC_ACCESSOR, OP_SET_CAR, 2, 0, SEXP_PAIR, 0, 0, "set-car!", 0, NULL), +_OP(OPC_ACCESSOR, OP_CDR, 1, 0, SEXP_PAIR, 0, 0, "cdr", 0, NULL), +_OP(OPC_ACCESSOR, OP_SET_CDR, 2, 0, SEXP_PAIR, 0, 0, "set-cdr!", 0, NULL), +_OP(OPC_ACCESSOR, OP_VECTOR_REF,2,0, SEXP_VECTOR, SEXP_FIXNUM, 0,"vector-ref", 0, NULL), +_OP(OPC_ACCESSOR, OP_VECTOR_SET,3,0, SEXP_VECTOR, SEXP_FIXNUM, 0,"vector-set!", 0, NULL), +_OP(OPC_ACCESSOR, OP_VECTOR_LENGTH,1,0, SEXP_VECTOR, 0, 0,"vector-length", 0, NULL), +_OP(OPC_ACCESSOR, OP_STRING_REF,2,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-ref", 0, NULL), +_OP(OPC_ACCESSOR, OP_STRING_SET,3,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-set!", 0, NULL), +_OP(OPC_ACCESSOR, OP_STRING_LENGTH,1,0, SEXP_STRING, 0, 0,"string-length", 0, NULL), +_OP(OPC_GENERIC, OP_FIX2FLO, 1, 0, 0, 0, 0, "exact->inexact", 0, NULL), +_OP(OPC_GENERIC, OP_FLO2FIX, 1, 0, 0, 0, 0, "inexact->exact", 0, NULL), +_OP(OPC_GENERIC, OP_CHAR2INT, 1, 0, SEXP_CHAR, 0, 0, "char->integer", 0, NULL), +_OP(OPC_GENERIC, OP_INT2CHAR, 1, 0, SEXP_FIXNUM, 0, 0, "integer->char", 0, NULL), +_OP(OPC_GENERIC, OP_CHAR_UPCASE, 1, 0, SEXP_CHAR, 0, 0, "char-upcase", 0, NULL), +_OP(OPC_GENERIC, OP_CHAR_DOWNCASE, 1, 0, SEXP_CHAR, 0, 0, "char-downcase", 0, NULL), +_OP(OPC_ARITHMETIC, OP_ADD, 0, 1, SEXP_FIXNUM, 0, 0, "+", sexp_make_integer(0), NULL), +_OP(OPC_ARITHMETIC, OP_MUL, 0, 1, SEXP_FIXNUM, 0, 0, "*", sexp_make_integer(1), NULL), +_OP(OPC_ARITHMETIC_INV, OP_SUB, 0, 1, SEXP_FIXNUM, 0, OP_NEGATIVE, "-", 0, NULL), +_OP(OPC_ARITHMETIC_INV, OP_DIV, 0, 1, SEXP_FIXNUM, 0, OP_INVERSE, "/", 0, NULL), +_OP(OPC_ARITHMETIC, OP_QUOTIENT, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, 0, "quotient", 0, NULL), +_OP(OPC_ARITHMETIC, OP_REMAINDER, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, 0, "remainder", 0, NULL), +_OP(OPC_ARITHMETIC_CMP, OP_LT, 0, 1, SEXP_FIXNUM, 0, 0, "<", 0, NULL), +_OP(OPC_ARITHMETIC_CMP, OP_LE, 0, 1, SEXP_FIXNUM, 0, 0, "<=", 0, NULL), +_OP(OPC_ARITHMETIC_CMP, OP_LT, 0, 1, SEXP_FIXNUM, 0, 1, ">", 0, NULL), +_OP(OPC_ARITHMETIC_CMP, OP_LE, 0, 1, SEXP_FIXNUM, 0, 1, ">=", 0, NULL), +_OP(OPC_ARITHMETIC_CMP, OP_EQN, 0, 1, SEXP_FIXNUM, 0, 0, "=", 0, NULL), +_OP(OPC_PREDICATE, OP_EQ, 2, 0, 0, 0, 0, "eq?", 0, NULL), +_OP(OPC_CONSTRUCTOR, OP_CONS, 2, 0, 0, 0, 0, "cons", 0, NULL), +_OP(OPC_CONSTRUCTOR, OP_MAKE_VECTOR, 1, 1, SEXP_FIXNUM, 0, 0, "make-vector", SEXP_VOID, NULL), +_OP(OPC_CONSTRUCTOR, OP_MAKE_PROCEDURE, 4, 0, 0, 0, 0, "make-procedure", 0, NULL), +_OP(OPC_TYPE_PREDICATE, OP_NULLP, 1, 0, 0, 0, 0, "null?", 0, NULL), +_OP(OPC_TYPE_PREDICATE, OP_EOFP, 1, 0, 0, 0, 0, "eof-object?", 0, NULL), +_OP(OPC_TYPE_PREDICATE, OP_SYMBOLP, 1, 0, 0, 0, 0, "symbol?", 0, NULL), +_OP(OPC_TYPE_PREDICATE, OP_CHARP, 1, 0, 0, 0, 0, "char?", 0, NULL), +_OP(OPC_TYPE_PREDICATE, OP_INTEGERP, 1, 0, 0, 0, 0, "fixnum?", 0, NULL), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "pair?", 0, (sexp)SEXP_PAIR), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "string?", 0, (sexp)SEXP_STRING), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "vector?", 0, (sexp)SEXP_VECTOR), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "flonum?", 0, (sexp)SEXP_FLONUM), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "closure?", 0, (sexp)SEXP_PROCEDURE), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "opcode?", 0, (sexp)SEXP_OPCODE), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "input-port?", 0, (sexp)SEXP_IPORT), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "output-port?", 0, (sexp)SEXP_OPORT), +_OP(OPC_GENERIC, OP_APPLY1, 2, 0, SEXP_PROCEDURE, SEXP_PAIR, 0, "apply1", 0, NULL), +_OP(OPC_GENERIC, OP_CALLCC, 1, SEXP_PROCEDURE, 0, 0, 0, "call-with-current-continuation", 0, NULL), +_OP(OPC_GENERIC, OP_RAISE, 1, SEXP_STRING, 0, 0, 0, "raise", 0, NULL), +_OP(OPC_IO, OP_WRITE, 1, 3, 0, SEXP_OPORT, 0, "write", (sexp)"*current-output-port*", NULL), +_OP(OPC_IO, OP_DISPLAY, 1, 3, 0, SEXP_OPORT, 0, "display", (sexp)"*current-output-port*", NULL), +_OP(OPC_IO, OP_WRITE_CHAR, 1, 3, 0, SEXP_OPORT, 0, "write-char", (sexp)"*current-output-port*", NULL), +_OP(OPC_IO, OP_NEWLINE, 0, 3, 0, SEXP_OPORT, 0, "newline", (sexp)"*current-output-port*", NULL), +_OP(OPC_IO, OP_FLUSH_OUTPUT, 0, 3, 0, SEXP_OPORT, 0, "flush-output", (sexp)"*current-output-port*", NULL), +_OP(OPC_IO, OP_READ, 0, 3, 0, SEXP_IPORT, 0, "read", (sexp)"*current-input-port*", NULL), +_OP(OPC_IO, OP_READ_CHAR, 0, 3, 0, SEXP_IPORT, 0, "read-char", (sexp)"*current-input-port*", NULL), +_OP(OPC_IO, OP_PEEK_CHAR, 0, 3, 0, SEXP_IPORT, 0, "peek-char", (sexp)"*current-input-port*", NULL), +_OP(OPC_GENERIC, OP_EVAL, 1, 3, 0, 0, 0, "eval", (sexp)"*interaction-environment*", NULL), +_FN2(0, 0, "equal?", 0, sexp_equalp), +_FN1(0, "list?", 0, sexp_listp), +_FN1(0, "identifier?", 0, sexp_identifierp), +_FN1(0, "identifier->symbol", 0, sexp_syntactic_closure_expr), +_FN4(0, SEXP_ENV, "identifier=?", 0, sexp_identifier_eq), +_FN1(SEXP_PAIR, "length", 0, sexp_length), +_FN1(SEXP_PAIR, "reverse", 0, sexp_reverse), +_FN1(SEXP_PAIR, "reverse!", 0, sexp_nreverse), +_FN2(SEXP_PAIR, SEXP_PAIR, "append2", 0, sexp_append2), +_FN1(SEXP_PAIR, "list->vector", 0, sexp_list_to_vector), +_FN1(SEXP_STRING, "open-input-file", 0, sexp_open_input_file), +_FN1(SEXP_STRING, "open-output-file", 0, sexp_open_output_file), +_FN1(SEXP_IPORT, "close-input-port", 0, sexp_close_port), +_FN1(SEXP_OPORT, "close-output-port", 0, sexp_close_port), +_FN1(SEXP_FIXNUM, "null-environment", 0, sexp_make_null_env), +_FN1(SEXP_FIXNUM, "scheme-report-environment", 0, sexp_make_standard_env), +_FN2(SEXP_STRING, SEXP_ENV, "%load", 0, sexp_load), +_FN2(SEXP_EXCEPTION, SEXP_OPORT, "print-exception", 0, sexp_print_exception), +_FN1(SEXP_EXCEPTION, "exception-type", 0, sexp_exception_type_func), +_FN6(SEXP_SYMBOL, SEXP_STRING, "make-exception", 0, sexp_make_exception), +_FN2OPT(SEXP_FIXNUM, SEXP_CHAR, "make-string", sexp_make_character(' '), sexp_make_string), +_FN3(SEXP_STRING, SEXP_STRING, "string-cmp", 0, sexp_string_cmp), +_FN3(SEXP_STRING, SEXP_FIXNUM, "substring", 0, sexp_substring), +_FN1(SEXP_STRING, "string->symbol", 0, sexp_string_to_symbol), +_FN1(SEXP_PAIR, "string-concatenate", 0, sexp_string_concatenate), +_FN2(0, SEXP_PAIR, "memq", 0, sexp_memq), +_FN2(0, SEXP_PAIR, "assq", 0, sexp_assq), +_FN3(SEXP_ENV, SEXP_PAIR, "make-syntactic-closure", 0, sexp_make_synclo), +_PARAM("current-input-port", (sexp)"*current-input-port*", SEXP_IPORT), +_PARAM("current-output-port", (sexp)"*current-output-port*", SEXP_OPORT), +_PARAM("current-error-port", (sexp)"*current-error-port*", SEXP_OPORT), +_PARAM("current-exception-handler", (sexp)"*current-exception-handler*", SEXP_PROCEDURE), +_PARAM("interaction-environment", (sexp)"*interaction-environment*", SEXP_ENV), +#if USE_MATH +_FN1(0, "exp", 0, sexp_exp), +_FN1(0, "log", 0, sexp_log), +_FN1(0, "sin", 0, sexp_sin), +_FN1(0, "cos", 0, sexp_cos), +_FN1(0, "tan", 0, sexp_tan), +_FN1(0, "asin", 0, sexp_asin), +_FN1(0, "acos", 0, sexp_acos), +_FN1(0, "atan1", 0, sexp_atan), +_FN1(0, "sqrt", 0, sexp_sqrt), +_FN1(0, "round", 0, sexp_round), +_FN1(0, "truncate", 0, sexp_trunc), +_FN1(0, "floor", 0, sexp_floor), +_FN1(0, "ceiling", 0, sexp_ceiling), +_FN2(0, 0, "expt", 0, sexp_expt), +#endif +_FN0("open-output-string", 0, sexp_make_output_string_port), +_FN1(SEXP_STRING, "open-input-string", 0, sexp_make_input_string_port), +_FN1(SEXP_OPORT, "get-output-string", 0, sexp_get_output_string), +#if USE_DEBUG +_FN2(SEXP_PROCEDURE, SEXP_OPORT, "disasm", 0, sexp_disasm), +#endif +}; + diff --git a/opt/sexp-huff.c b/opt/sexp-huff.c new file mode 100644 index 00000000..abf6bc9f --- /dev/null +++ b/opt/sexp-huff.c @@ -0,0 +1,128 @@ + {12, 0x0C00}, /* '\x00' */ + {15, 0x0000}, /* '\x01' */ + {15, 0x4000}, /* '\x02' */ + {15, 0x2000}, /* '\x03' */ + {15, 0x6000}, /* '\x04' */ + {15, 0x0800}, /* '\x05' */ + {15, 0x4800}, /* '\x06' */ + {15, 0x2800}, /* '\x07' */ + {15, 0x6800}, /* '\x08' */ + {15, 0x1800}, /* '\x09' */ + {15, 0x5800}, /* '\x0a' */ + {15, 0x3800}, /* '\x0b' */ + {15, 0x7800}, /* '\x0c' */ + {15, 0x0100}, /* '\x0d' */ + {15, 0x4100}, /* '\x0e' */ + {15, 0x2100}, /* '\x0f' */ + {15, 0x6100}, /* '\x10' */ + {15, 0x1100}, /* '\x11' */ + {15, 0x5100}, /* '\x12' */ + {15, 0x3100}, /* '\x13' */ + {15, 0x7100}, /* '\x14' */ + {15, 0x0900}, /* '\x15' */ + {15, 0x4900}, /* '\x16' */ + {15, 0x2900}, /* '\x17' */ + {15, 0x6900}, /* '\x18' */ + {15, 0x1900}, /* '\x19' */ + {15, 0x5900}, /* '\x1a' */ + {15, 0x3900}, /* '\x1b' */ + {15, 0x7900}, /* '\x1c' */ + {15, 0x0500}, /* '\x1d' */ + {15, 0x4500}, /* '\x1e' */ + {15, 0x2500}, /* '\x1f' */ + {15, 0x6500}, /* '\x20' */ + { 8, 0x0040}, /* '!' */ + {15, 0x1500}, /* '"' */ + {15, 0x5500}, /* '#' */ + {15, 0x3500}, /* '$' */ + {15, 0x7500}, /* '%' */ + {15, 0x0D00}, /* '&' */ + {15, 0x4D00}, /* '\'' */ + {15, 0x2D00}, /* '(' */ + {15, 0x6D00}, /* ')' */ + {11, 0x0300}, /* '*' */ + {10, 0x0180}, /* '+' */ + {15, 0x1D00}, /* ',' */ + { 4, 0x000D}, /* '-' */ + {15, 0x5D00}, /* '.' */ + {10, 0x0380}, /* '/' */ + {15, 0x3D00}, /* '0' */ + {15, 0x7D00}, /* '1' */ + {14, 0x0080}, /* '2' */ + {14, 0x2080}, /* '3' */ + {14, 0x1080}, /* '4' */ + {14, 0x3080}, /* '5' */ + {14, 0x0880}, /* '6' */ + {14, 0x2880}, /* '7' */ + {14, 0x1880}, /* '8' */ + {14, 0x3880}, /* '9' */ + {14, 0x0480}, /* ':' */ + {14, 0x2480}, /* ';' */ + { 7, 0x0050}, /* '<' */ + { 7, 0x0042}, /* '=' */ + { 7, 0x0022}, /* '>' */ + { 5, 0x0009}, /* '?' */ + {14, 0x1480}, /* '@' */ + {14, 0x3480}, /* 'A' */ + {14, 0x0C80}, /* 'B' */ + {14, 0x2C80}, /* 'C' */ + {14, 0x1C80}, /* 'D' */ + {14, 0x3C80}, /* 'E' */ + {14, 0x0280}, /* 'F' */ + {14, 0x2280}, /* 'G' */ + {14, 0x1280}, /* 'H' */ + {14, 0x3280}, /* 'I' */ + {14, 0x0A80}, /* 'J' */ + {14, 0x2A80}, /* 'K' */ + {14, 0x1A80}, /* 'L' */ + {14, 0x3A80}, /* 'M' */ + {14, 0x0680}, /* 'N' */ + {14, 0x2680}, /* 'O' */ + {14, 0x1680}, /* 'P' */ + {14, 0x3680}, /* 'Q' */ + {14, 0x0E80}, /* 'R' */ + {14, 0x2E80}, /* 'S' */ + {14, 0x1E80}, /* 'T' */ + {14, 0x3E80}, /* 'U' */ + {14, 0x0200}, /* 'V' */ + {14, 0x2200}, /* 'W' */ + {14, 0x1200}, /* 'X' */ + {14, 0x3200}, /* 'Y' */ + {14, 0x0A00}, /* 'Z' */ + {14, 0x2A00}, /* '[' */ + {14, 0x1A00}, /* '\\' */ + {14, 0x3A00}, /* ']' */ + {14, 0x0600}, /* '^' */ + {14, 0x2600}, /* '_' */ + {14, 0x1600}, /* '`' */ + { 3, 0x0007}, /* 'a' */ + { 7, 0x0020}, /* 'b' */ + { 4, 0x0004}, /* 'c' */ + { 5, 0x001A}, /* 'd' */ + { 4, 0x0006}, /* 'e' */ + { 7, 0x0002}, /* 'f' */ + { 5, 0x0011}, /* 'g' */ + { 6, 0x0012}, /* 'h' */ + { 4, 0x000C}, /* 'i' */ + {12, 0x0400}, /* 'j' */ + { 8, 0x00C0}, /* 'k' */ + { 5, 0x0018}, /* 'l' */ + { 6, 0x0032}, /* 'm' */ + { 4, 0x0005}, /* 'n' */ + { 5, 0x000A}, /* 'o' */ + { 5, 0x0001}, /* 'p' */ + { 7, 0x0070}, /* 'q' */ + { 3, 0x0003}, /* 'r' */ + { 5, 0x0008}, /* 's' */ + { 4, 0x000E}, /* 't' */ + { 5, 0x0019}, /* 'u' */ + { 7, 0x0062}, /* 'v' */ + { 7, 0x0030}, /* 'w' */ + { 7, 0x0060}, /* 'x' */ + { 7, 0x0010}, /* 'y' */ + {11, 0x0700}, /* 'z' */ + {14, 0x3600}, /* '{' */ + {14, 0x0E00}, /* '|' */ + {14, 0x2E00}, /* '}' */ + {14, 0x1E00}, /* '~' */ + {14, 0x3E00}, /* '\x7f' */ diff --git a/opt/sexp-hufftabs.c b/opt/sexp-hufftabs.c new file mode 100644 index 00000000..7704184f --- /dev/null +++ b/opt/sexp-hufftabs.c @@ -0,0 +1,92 @@ +/* auto-generated by ./symhuff.scm on Sun Feb 25 23:12:52 2007 */ + +char _huff_tab21[] = { + '\x01', '\x00', '\x03', '\x00', '\x02', '\x00', '\x04', '\x00', +}; + +char _huff_tab19[] = { + '\x01', 'j', '\x01', '\x00', +}; + +char _huff_tab20[] = { + '\x05', '\x09', '\x07', '\x0b', '\x06', '\x0a', '\x08', '\x0c', +}; + +char _huff_tab18[] = { + '2', ':', '6', 'B', '4', '@', '8', 'D', + '3', ';', '7', 'C', '5', 'A', '9', 'E', +}; + +char _huff_tab17[] = { + '\x0d', '\x1d', '\x15', '&', '\x11', '"', '\x19', ',', + '\x0f', '\x1f', '\x17', '(', '\x13', '$', '\x1b', '0', + '\x0e', '\x1e', '\x16', '\'', '\x12', '#', '\x1a', '.', + '\x10', '\x20', '\x18', ')', '\x14', '%', '\x1c', '1', +}; + +char _huff_tab16[] = { + 'V', '^', 'Z', '|', 'X', '`', '\\', '~', + 'W', '_', '[', '}', 'Y', '{', ']', '\x7f', +}; + +char _huff_tab15[] = { + 'F', 'N', 'J', 'R', 'H', 'P', 'L', 'T', + 'G', 'O', 'K', 'S', 'I', 'Q', 'M', 'U', +}; + +char _huff_tab13[] = { + '\x00', '\x00', '\x00', '+', '\x00', '\x00', '\x00', '/', +}; + +char _huff_tab14[] = { + '*', 'z', +}; + +char _huff_tab11[] = { + '\x00', 'b', '\x00', 'x', +}; + +char _huff_tab12[] = { + '!', 'k', +}; + +char _huff_tab9[] = { + '\x00', 's', '\x00', 'l', +}; + +char _huff_tab10[] = { + 'y', 'w', '<', 'q', +}; + +char _huff_tab8[] = { + 'p', '?', 'g', 'u', +}; + +char _huff_tab7[] = { + 'f', '>', '=', 'v', +}; + +char _huff_tab5[] = { + '\x00', 'o', '\x00', 'd', +}; + +char _huff_tab6[] = { + 'h', 'm', +}; + +char _huff_tab4[] = { + 'c', 'i', +}; + +char _huff_tab3[] = { + 'n', '-', +}; + +char _huff_tab1[] = { + '\x00', '\x00', '\x00', 'r', '\x00', '\x00', '\x00', 'a', +}; + +char _huff_tab2[] = { + 'e', 't', +}; + diff --git a/opt/sexp-unhuff.c b/opt/sexp-unhuff.c new file mode 100644 index 00000000..fa142e16 --- /dev/null +++ b/opt/sexp-unhuff.c @@ -0,0 +1,71 @@ +/* auto-generated by ./symhuff.scm on Sun Feb 25 23:12:52 2007 */ + +res = c & 7; +c = c >> 3; +if (res == 0) { + res = c & 3; + c = c >> 2; + if (res == 0) { + res = c & 3; + c = c >> 2; + if (res == 0) { + res = c & 7; + c = c >> 3; + if (res == 0) { + res = c & 3; + c = c >> 2; + if (res == 0) { + res = _huff_tab21[c & 7]; + c = c >> 3; + } else if ((res = _huff_tab19[res]) == '\x01') { + res = _huff_tab20[c & 7]; + c = c >> 3; + } + } else if (res == 1) { + res = _huff_tab18[c & 15]; + c = c >> 4; + } else if (res == 2) { + res = _huff_tab17[c & 31]; + c = c >> 5; + } else if (res == 4) { + res = _huff_tab16[c & 15]; + c = c >> 4; + } else if (res == 5) { + res = _huff_tab15[c & 15]; + c = c >> 4; + } else if ((res = _huff_tab13[res]) == '\x00') { + res = _huff_tab14[c & 1]; + c = c >> 1; + } + } else if ((res = _huff_tab11[res]) == '\x00') { + res = _huff_tab12[c & 1]; + c = c >> 1; + } + } else if ((res = _huff_tab9[res]) == '\x00') { + res = _huff_tab10[c & 3]; + c = c >> 2; + } + } else if (res == 1) { + res = _huff_tab8[c & 3]; + c = c >> 2; + } else if (res == 2) { + res = c & 3; + c = c >> 2; + if (res == 0) { + res = _huff_tab7[c & 3]; + c = c >> 2; + } else if ((res = _huff_tab5[res]) == '\x00') { + res = _huff_tab6[c & 1]; + c = c >> 1; + } + } else if (res == 4) { + res = _huff_tab4[c & 1]; + c = c >> 1; + } else if (res == 5) { + res = _huff_tab3[c & 1]; + c = c >> 1; + } else if ((res = _huff_tab1[res]) == '\x00') { + res = _huff_tab2[c & 1]; + c = c >> 1; + } + diff --git a/sexp.c b/sexp.c new file mode 100644 index 00000000..9b909936 --- /dev/null +++ b/sexp.c @@ -0,0 +1,1350 @@ +/* sexp.c -- standalone sexp library implementation */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#define SEXP_API +#include "chibi/sexp.h" + +/* optional huffman-compressed immediate symbols */ +struct sexp_huff_entry { + unsigned char len; + unsigned short bits; +}; + +#if USE_HUFF_SYMS +#include "opt/sexp-hufftabs.c" +static struct sexp_huff_entry huff_table[] = { +#include "opt/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_ */ +}; + +static int digit_value (c) { + return (((c)<='9') ? ((c) - '0') : ((toupper(c) - 'A') + 10)); +} + +static int hex_digit (n) { + return ((n<=9) ? ('0' + n) : ('A' + n - 10)); +} + +static int is_separator(int c) { + return 0= sexp_make_integer(0))) { + sexp_write_string(ctx, " on line ", out); + sexp_write(ctx, sexp_cdr(sexp_exception_source(exn)), out); + } + if (sexp_stringp(sexp_car(sexp_exception_source(exn)))) { + sexp_write_string(ctx, " of file ", out); + sexp_write_string(ctx, sexp_string_data(sexp_car(sexp_exception_source(exn))), out); + } + } + sexp_write_string(ctx, ": ", out); + sexp_write_string(ctx, sexp_string_data(sexp_exception_message(exn)), out); + if (sexp_exception_irritants(exn) + && sexp_pairp(sexp_exception_irritants(exn))) { + if (sexp_nullp(sexp_cdr(sexp_exception_irritants(exn)))) { + sexp_write_string(ctx, ": ", out); + sexp_write(ctx, sexp_car(sexp_exception_irritants(exn)), out); + sexp_write_string(ctx, "\n", out); + } else { + sexp_write_string(ctx, "\n", out); + for (ls=sexp_exception_irritants(exn); + sexp_pairp(ls); ls=sexp_cdr(ls)) { + sexp_write_string(ctx, " ", out); + sexp_write(ctx, sexp_car(ls), out); + sexp_write_char(ctx, '\n', out); + } + } + } else { + sexp_write_char(ctx, '\n', out); + } + } else { + sexp_write_string(ctx, ": ", out); + if (sexp_stringp(exn)) + sexp_write_string(ctx, sexp_string_data(exn), out); + else + sexp_write(ctx, exn, out); + sexp_write_char(ctx, '\n', out); + } + return SEXP_VOID; +} + +static sexp sexp_read_error (sexp ctx, char *msg, sexp irritants, sexp port) { + sexp res; + sexp_gc_var(ctx, name, s_name); + sexp_gc_var(ctx, str, s_str); + sexp_gc_var(ctx, irr, s_irr); + sexp_gc_var(ctx, src, s_src); + sexp_gc_preserve(ctx, name, s_name); + sexp_gc_preserve(ctx, str, s_str); + sexp_gc_preserve(ctx, irr, s_irr); + sexp_gc_preserve(ctx, src, s_src); + name = (sexp_port_name(port) ? sexp_port_name(port) : SEXP_FALSE); + name = sexp_cons(ctx, name, sexp_make_integer(sexp_port_line(port))); + str = sexp_c_string(ctx, msg, -1); + irr = ((sexp_pairp(irritants) || sexp_nullp(irritants)) + ? irritants : sexp_list1(ctx, irritants)); + res = sexp_make_exception(ctx, the_read_error_symbol, + str, irr, SEXP_FALSE, name); + sexp_gc_release(ctx, name, s_name); + return res; +} + +/*************************** list utilities ***************************/ + +sexp sexp_cons (sexp ctx, sexp head, sexp tail) { + sexp pair = sexp_alloc_type(ctx, pair, SEXP_PAIR); + sexp_car(pair) = head; + sexp_cdr(pair) = tail; + sexp_pair_source(pair) = SEXP_FALSE; + return pair; +} + +sexp sexp_list2 (sexp ctx, sexp a, sexp b) { + sexp_gc_var(ctx, res, s_res); + sexp_gc_preserve(ctx, res, s_res); + res = sexp_cons(ctx, b, SEXP_NULL); + res = sexp_cons(ctx, a, res); + sexp_gc_release(ctx, res, s_res); + return res; +} + +sexp sexp_listp (sexp ctx, sexp hare) { + sexp turtle; + if (! sexp_pairp(hare)) + return sexp_make_boolean(sexp_nullp(hare)); + turtle = hare; + hare = sexp_cdr(hare); + for ( ; sexp_pairp(hare); turtle=sexp_cdr(turtle)) { + if (hare == turtle) return SEXP_FALSE; + hare = sexp_cdr(hare); + if (sexp_pairp(hare)) hare = sexp_cdr(hare); + } + return sexp_make_boolean(sexp_nullp(hare)); +} + +sexp sexp_memq (sexp ctx, 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 ctx, sexp x, sexp ls) { + while (sexp_pairp(ls)) + if (sexp_pairp(sexp_car(ls)) && (x == sexp_caar(ls))) + return sexp_car(ls); + else + ls = sexp_cdr(ls); + return SEXP_FALSE; +} + +sexp sexp_reverse (sexp ctx, sexp ls) { + sexp_gc_var(ctx, res, s_res); + sexp_gc_preserve(ctx, res, s_res); + for (res=SEXP_NULL; sexp_pairp(ls); ls=sexp_cdr(ls)) + res = sexp_cons(ctx, sexp_car(ls), res); + sexp_gc_release(ctx, res, s_res); + return res; +} + +sexp sexp_nreverse (sexp ctx, sexp ls) { + sexp a, b, tmp; + if (ls == SEXP_NULL) { + return ls; + } else if (! sexp_pairp(ls)) { + return SEXP_NULL; /* XXXX return an exception */ + } 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_append2 (sexp ctx, sexp a, sexp b) { + sexp_gc_var(ctx, a1, s_a1); + sexp_gc_var(ctx, b1, s_b1); + sexp_gc_preserve(ctx, a1, s_a1); + sexp_gc_preserve(ctx, b1, s_b1); + b1 = b; + for (a1=sexp_reverse(ctx, a); sexp_pairp(a1); a1=sexp_cdr(a1)) + b1 = sexp_cons(ctx, sexp_car(a1), b1); + sexp_gc_release(ctx, a1, s_a1); + return b1; +} + +sexp sexp_length (sexp ctx, sexp ls) { + sexp_uint_t res=0; + for ( ; sexp_pairp(ls); res++, ls=sexp_cdr(ls)) + ; + return sexp_make_integer(res); +} + +sexp sexp_equalp (sexp ctx, sexp a, sexp b) { + sexp_uint_t len; + sexp *v1, *v2; + loop: + if (a == b) + return SEXP_TRUE; +#if USE_IMMEDIATE_FLONUMS + if ((! sexp_pointerp(a)) || (! sexp_pointerp(b))) + return + sexp_make_boolean((a == b) + || (sexp_flonump(a) + && sexp_make_integer(sexp_flonum_value(a)) == b) + || (sexp_flonump(b) + && sexp_make_integer(sexp_flonum_value(b)) == a)); +#else + if (! sexp_pointerp(a)) + return sexp_make_boolean(sexp_integerp(a) && sexp_pointerp(b) + && (sexp_unbox_integer(a) + == sexp_flonum_value(b))); + else if (! sexp_pointerp(b)) + return sexp_make_boolean(sexp_integerp(b) && sexp_pointerp(a) + && (sexp_unbox_integer(b) + == sexp_flonum_value(a))); +#endif + if (sexp_pointer_tag(a) != sexp_pointer_tag(b)) + return SEXP_FALSE; + switch (sexp_pointer_tag(a)) { + case SEXP_PAIR: + if (sexp_equalp(ctx, sexp_car(a), sexp_car(b)) == SEXP_FALSE) + return SEXP_FALSE; + a = sexp_cdr(a); + b = sexp_cdr(b); + goto loop; + case SEXP_VECTOR: + len = sexp_vector_length(a); + if (len != sexp_vector_length(b)) + return SEXP_FALSE; + v1 = sexp_vector_data(a); + v2 = sexp_vector_data(b); + for (len--; len > 0; len--) + if (sexp_equalp(ctx, v1[len], v2[len]) == SEXP_FALSE) + return SEXP_FALSE; + return SEXP_TRUE; + case SEXP_STRING: + return sexp_make_boolean((sexp_string_length(a) == sexp_string_length(b)) + && (! strncmp(sexp_string_data(a), + sexp_string_data(b), + sexp_string_length(a)))); +#if ! USE_IMMEDIATE_FLONUMS + case SEXP_FLONUM: + return sexp_make_boolean(sexp_flonum_value(a) == sexp_flonum_value(b)); +#endif + default: + return SEXP_FALSE; + } +} + +/********************* strings, symbols, vectors **********************/ + +#if ! USE_IMMEDIATE_FLONUMS +sexp sexp_make_flonum(sexp ctx, double f) { + sexp x = sexp_alloc_type(ctx, flonum, SEXP_FLONUM); + sexp_flonum_value(x) = f; + return x; +} +#endif + +sexp sexp_make_string(sexp ctx, sexp len, sexp ch) { + sexp_sint_t clen = sexp_unbox_integer(len); + sexp s; + if (clen < 0) return sexp_type_exception(ctx, "negative length", len); + s = sexp_alloc_atomic(ctx, sexp_sizeof(string)+clen+1); + sexp_pointer_tag(s) = SEXP_STRING; + sexp_string_length(s) = clen; + if (sexp_charp(ch)) + memset(sexp_string_data(s), sexp_unbox_character(ch), clen); + sexp_string_data(s)[clen] = '\0'; + return s; +} + +sexp sexp_c_string(sexp ctx, char *str, sexp_sint_t slen) { + sexp_sint_t len = ((slen >= 0) ? slen : strlen(str)); + sexp s = sexp_make_string(ctx, sexp_make_integer(len), SEXP_VOID); + memcpy(sexp_string_data(s), str, len); + sexp_string_data(s)[len] = '\0'; + return s; +} + +sexp sexp_substring (sexp ctx, sexp str, sexp start, sexp end) { + sexp res; + if (! sexp_stringp(str)) + return sexp_type_exception(ctx, "not a string", str); + if (! sexp_integerp(start)) + return sexp_type_exception(ctx, "not a number", start); + if (sexp_not(end)) + end = sexp_make_integer(sexp_string_length(str)); + if (! sexp_integerp(end)) + return sexp_type_exception(ctx, "not a number", end); + if ((sexp_unbox_integer(start) < 0) + || (sexp_unbox_integer(start) > sexp_string_length(str)) + || (sexp_unbox_integer(end) < 0) + || (sexp_unbox_integer(end) > sexp_string_length(str)) + || (end < start)) + return sexp_range_exception(ctx, str, start, end); + res = sexp_make_string(ctx, sexp_fx_sub(end, start), SEXP_VOID); + memcpy(sexp_string_data(res), + sexp_string_data(str)+sexp_unbox_integer(start), + sexp_string_length(res)); + sexp_string_data(res)[sexp_string_length(res)] = '\0'; + return res; +} + +sexp sexp_string_concatenate (sexp ctx, sexp str_ls) { + sexp res, ls; + sexp_uint_t len=0; + char *p; + for (ls=str_ls; sexp_pairp(ls); ls=sexp_cdr(ls)) + if (! sexp_stringp(sexp_car(ls))) + return sexp_type_exception(ctx, "not a string", sexp_car(ls)); + else + len += sexp_string_length(sexp_car(ls)); + res = sexp_make_string(ctx, sexp_make_integer(len), SEXP_VOID); + p = sexp_string_data(res); + for (ls=str_ls; sexp_pairp(ls); ls=sexp_cdr(ls)) { + len = sexp_string_length(sexp_car(ls)); + memcpy(p, sexp_string_data(sexp_car(ls)), len); + p += len; + } + *p = '\0'; + return res; +} + +#define FNV_PRIME 16777619 +#define FNV_OFFSET_BASIS 2166136261uL + +#if USE_HASH_SYMS + +static sexp_uint_t sexp_string_hash(char *str, sexp_uint_t acc) { + while (*str) {acc *= FNV_PRIME; acc ^= *str++;} + return acc; +} + +#endif + +sexp sexp_intern(sexp ctx, char *str) { + struct sexp_huff_entry he; + sexp_uint_t len, res=FNV_OFFSET_BASIS, space=3, newbits, bucket; + char c, *p=str; + sexp ls; + sexp_gc_var(ctx, sym, s_sym); + +#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: +#if USE_HASH_SYMS + bucket = (sexp_string_hash(p, res) % SEXP_SYMBOL_TABLE_SIZE); +#else + bucket = 0; +#endif + len = strlen(str); + for (ls=sexp_symbol_table[bucket]; sexp_pairp(ls); ls=sexp_cdr(ls)) + if (! strncmp(str, sexp_string_data(sexp_symbol_string(sexp_car(ls))), len)) + return sexp_car(ls); + + /* not found, make a new symbol */ + sexp_gc_preserve(ctx, sym, s_sym); + sym = sexp_alloc_type(ctx, symbol, SEXP_SYMBOL); + sexp_symbol_string(sym) = sexp_c_string(ctx, str, len); + sexp_push(ctx, sexp_symbol_table[bucket], sym); + sexp_gc_release(ctx, sym, s_sym); + return sym; +} + +sexp sexp_string_to_symbol (sexp ctx, sexp str) { + return sexp_intern(ctx, sexp_string_data(str)); +} + +sexp sexp_make_vector(sexp ctx, sexp len, sexp dflt) { + sexp v, *x; + int i, clen = sexp_unbox_integer(len); + if (! clen) return the_empty_vector; + v = sexp_alloc_tagged(ctx, sexp_sizeof(vector) + clen*sizeof(sexp), + SEXP_VECTOR); + x = sexp_vector_data(v); + for (i=0; i= len) return 0; + if (n > (len - pos)) n = (len - pos); + memcpy(dst, sexp_string_data(sexp_stream_buf(vec))+pos, n); + sexp_stream_pos(vec) = sexp_make_integer(n); + return n; +} + +int sstream_write (void *vec, const char *src, int n) { + sexp_uint_t len, pos, newpos; + sexp newbuf; + len = sexp_unbox_integer(sexp_stream_size(vec)); + pos = sexp_unbox_integer(sexp_stream_pos(vec)); + newpos = pos+n; + if (newpos >= len) { + newbuf = sexp_make_string(sexp_stream_ctx(vec), + sexp_make_integer(newpos*2), + SEXP_VOID); + memcpy(sexp_string_data(newbuf), + sexp_string_data(sexp_stream_buf(vec)), + pos); + sexp_stream_buf(vec) = newbuf; + sexp_stream_size(vec) = sexp_make_integer(newpos*2); + } + memcpy(sexp_string_data(sexp_stream_buf(vec))+pos, src, n); + sexp_stream_pos(vec) = sexp_make_integer(newpos); + return n; +} + +off_t sstream_seek (void *vec, off_t offset, int whence) { + sexp_sint_t pos; + if (whence == SEEK_SET) { + pos = offset; + } else if (whence == SEEK_CUR) { + pos = sexp_unbox_integer(sexp_stream_pos(vec)) + offset; + } else { /* SEEK_END */ + pos = sexp_unbox_integer(sexp_stream_size(vec)) + offset; + } + sexp_stream_pos(vec) = sexp_make_integer(pos); + return pos; +} + +sexp sexp_make_input_string_port (sexp ctx, sexp str) { + FILE *in; + sexp res; + sexp_gc_var(ctx, cookie, s_cookie); + sexp_gc_preserve(ctx, cookie, s_cookie); + cookie = sexp_make_vector(ctx, sexp_make_integer(4), SEXP_VOID); + sexp_stream_ctx(cookie) = ctx; + sexp_stream_buf(cookie) = str; + sexp_stream_size(cookie) = sexp_make_integer(sexp_string_length(str)); + sexp_stream_pos(cookie) = sexp_make_integer(0); + in = funopen(cookie, &sstream_read, NULL, &sstream_seek, NULL); + res = sexp_make_input_port(ctx, in, SEXP_FALSE); + sexp_port_cookie(res) = cookie; + sexp_gc_release(ctx, cookie, s_cookie); + return res; +} + +sexp sexp_make_output_string_port (sexp ctx) { + FILE *out; + sexp res, size; + sexp_gc_var(ctx, cookie, s_cookie); + sexp_gc_preserve(ctx, cookie, s_cookie); + size = sexp_make_integer(SEXP_INIT_STRING_PORT_SIZE); + cookie = sexp_make_vector(ctx, sexp_make_integer(4), SEXP_VOID); + sexp_stream_ctx(cookie) = ctx; + sexp_stream_buf(cookie) = sexp_make_string(ctx, size, SEXP_VOID); + sexp_stream_size(cookie) = size; + sexp_stream_pos(cookie) = sexp_make_integer(0); + out = funopen(cookie, NULL, &sstream_write, &sstream_seek, NULL); + res = sexp_make_output_port(ctx, out, SEXP_FALSE); + sexp_port_cookie(res) = cookie; + sexp_gc_release(ctx, cookie, s_cookie); + return res; +} + +sexp sexp_get_output_string (sexp ctx, sexp port) { + sexp cookie = sexp_port_cookie(port); + fflush(sexp_port_stream(port)); + return sexp_substring(ctx, + sexp_stream_buf(cookie), + sexp_make_integer(0), + sexp_stream_pos(cookie)); +} + +#else + +sexp sexp_make_input_string_port (sexp ctx, sexp str) { + FILE *in = fmemopen(sexp_string_data(str), sexp_string_length(str), "r"); + sexp res = sexp_make_input_port(ctx, in, SEXP_FALSE); + sexp_port_cookie(res) = str; /* for gc preservation */ + return res; +} + +sexp sexp_make_output_string_port (sexp ctx) { + sexp res = sexp_make_output_port(ctx, NULL, SEXP_FALSE); + sexp_port_stream(res) + = open_memstream(&sexp_port_buf(res), &sexp_port_size(res)); + return res; +} + +sexp sexp_get_output_string (sexp ctx, sexp port) { + fflush(sexp_port_stream(port)); + return sexp_c_string(ctx, sexp_port_buf(port), sexp_port_size(port)); +} + +#endif + +#else + +#define SEXP_PORT_BUFFER_SIZE 4096 + +int sexp_buffered_read_char (sexp ctx, sexp p) { + if (sexp_port_offset(p) < sexp_port_size(p)) { + return sexp_port_buf(p)[sexp_port_offset(p)++]; + } else if (! sexp_port_stream(p)) { + return EOF; + } else { + sexp_port_size(p) + = fread(sexp_port_buf(p), 1, SEXP_PORT_BUFFER_SIZE, sexp_port_stream(p)); + sexp_port_offset(p) = 0; + return ((sexp_port_offset(p) < sexp_port_size(p)) + ? sexp_port_buf(p)[sexp_port_offset(p)++] : EOF); + } +} + +sexp sexp_buffered_write_char (sexp ctx, int c, sexp p) { + if (sexp_port_offset(p) >= sexp_port_size(p)) + sexp_buffered_flush(ctx, p); + sexp_port_buf(p)[sexp_port_offset(p)++] = c; + return SEXP_VOID; +} + +sexp sexp_buffered_write_string_n (sexp ctx, char *str, sexp_uint_t len, sexp p) { + if (sexp_port_offset(p) >= sexp_port_size(p)) + sexp_buffered_flush(ctx, p); + memcpy(sexp_port_buf(p)+sexp_port_offset(p), str, len); + sexp_port_offset(p) += len; + return SEXP_VOID; +} + +sexp sexp_buffered_write_string (sexp ctx, char *str, sexp p) { + return sexp_buffered_write_string_n(ctx, str, strlen(str), p); +} + +sexp sexp_buffered_flush (sexp ctx, sexp p) { + sexp_gc_var(ctx, tmp, s_tmp); + if (! sexp_oportp(p)) + return sexp_type_exception(ctx, "not an output-port", p); + else if (! sexp_port_openp(p)) + return sexp_user_exception(ctx, SEXP_FALSE, "port is closed", p); + else { + if (sexp_port_stream(p)) { + fwrite(sexp_port_buf(p), 1, sexp_port_offset(p), sexp_port_stream(p)); + fflush(sexp_port_stream(p)); + } else if (sexp_port_offset(p) > 0) { + sexp_gc_preserve(ctx, tmp, s_tmp); + tmp = sexp_c_string(ctx, sexp_port_buf(p), sexp_port_offset(p)); + sexp_push(ctx, sexp_port_cookie(p), tmp); + sexp_gc_release(ctx, tmp, s_tmp); + } + sexp_port_offset(p) = 0; + return SEXP_VOID; + } +} + +sexp sexp_make_input_string_port (sexp ctx, sexp str) { + sexp res = sexp_make_input_port(ctx, NULL, SEXP_FALSE); + sexp_port_cookie(res) = str; + sexp_port_buf(res) = sexp_string_data(str); + sexp_port_offset(res) = 0; + sexp_port_size(res) = sexp_string_length(str); + return res; +} + +sexp sexp_make_output_string_port (sexp ctx) { + sexp res = sexp_make_output_port(ctx, NULL, SEXP_FALSE); + sexp_port_buf(res) = (char*) malloc(SEXP_PORT_BUFFER_SIZE); + sexp_port_size(res) = SEXP_PORT_BUFFER_SIZE; + sexp_port_offset(res) = 0; + sexp_port_cookie(res) = SEXP_NULL; + return res; +} + +sexp sexp_get_output_string (sexp ctx, sexp out) { + sexp res; + sexp_gc_var(ctx, ls, s_ls); + sexp_gc_var(ctx, tmp, s_tmp); + sexp_gc_preserve(ctx, ls, s_ls); + sexp_gc_preserve(ctx, tmp, s_tmp); + if (sexp_port_offset(out) > 0) { + tmp = sexp_c_string(ctx, sexp_port_buf(out), sexp_port_offset(out)); + ls = sexp_cons(ctx, tmp, sexp_port_cookie(out)); + } else { + ls = sexp_port_cookie(out); + } + res = sexp_string_concatenate(ctx, ls); + sexp_gc_release(ctx, ls, s_ls); + return res; +} + +#endif + +sexp sexp_make_input_port (sexp ctx, FILE* in, sexp name) { + sexp p = sexp_alloc_type(ctx, port, SEXP_IPORT); + sexp_port_stream(p) = in; + sexp_port_name(p) = name; + sexp_port_line(p) = 1; + sexp_port_buf(p) = NULL; + sexp_port_openp(p) = 1; + sexp_port_sourcep(p) = 1; + sexp_port_cookie(p) = SEXP_VOID; + return p; +} + +sexp sexp_make_output_port (sexp ctx, FILE* out, sexp name) { + sexp p = sexp_make_input_port(ctx, out, name); + sexp_pointer_tag(p) = SEXP_OPORT; + return p; +} + +void sexp_write (sexp ctx, sexp obj, sexp out) { + unsigned long len, c, res; + long i=0; + double f; + sexp x, *elts; + char *str=NULL, numbuf[20]; + + if (! obj) { + sexp_write_string(ctx, "#", out); /* shouldn't happen */ + } else if (sexp_pointerp(obj)) { + switch (sexp_pointer_tag(obj)) { + case SEXP_PAIR: + sexp_write_char(ctx, '(', out); + sexp_write(ctx, sexp_car(obj), out); + for (x=sexp_cdr(obj); sexp_pairp(x); x=sexp_cdr(x)) { + sexp_write_char(ctx, ' ', out); + sexp_write(ctx, sexp_car(x), out); + } + if (! sexp_nullp(x)) { + sexp_write_string(ctx, " . ", out); + sexp_write(ctx, x, out); + } + sexp_write_char(ctx, ')', out); + break; + case SEXP_VECTOR: + len = sexp_vector_length(obj); + elts = sexp_vector_data(obj); + if (len == 0) { + sexp_write_string(ctx, "#()", out); + } else { + sexp_write_string(ctx, "#(", out); + sexp_write(ctx, elts[0], out); + for (i=1; i", out); + break; + case SEXP_STRING: + sexp_write_char(ctx, '"', out); + i = sexp_string_length(obj); + str = sexp_string_data(obj); + for ( ; i>0; str++, i--) { + switch (str[0]) { + case '\\': sexp_write_string(ctx, "\\\\", out); break; + case '"': sexp_write_string(ctx, "\\\"", out); break; + case '\n': sexp_write_string(ctx, "\\n", out); break; + case '\r': sexp_write_string(ctx, "\\r", out); break; + case '\t': sexp_write_string(ctx, "\\t", out); break; + default: sexp_write_char(ctx, str[0], out); + } + } + sexp_write_char(ctx, '"', out); + break; + case SEXP_SYMBOL: + i = sexp_string_length(sexp_symbol_string(obj)); + str = sexp_string_data(sexp_symbol_string(obj)); + for ( ; i>0; str++, i--) { + if ((str[0] == '\\') || is_separator(str[0])) + sexp_write_char(ctx, '\\', out); + sexp_write_char(ctx, str[0], out); + } + break; + default: + i = sexp_pointer_tag(obj); + sexp_write_string(ctx, "#<", out); + sexp_write_string(ctx, + (i < SEXP_NUM_TYPES) + ? sexp_type_name(&(sexp_type_specs[i])) : "invalid", + out); + sexp_write_char(ctx, '>', out); + break; + } + } else if (sexp_integerp(obj)) { + sprintf(numbuf, "%ld", sexp_unbox_integer(obj)); + sexp_write_string(ctx, numbuf, out); +#if USE_IMMEDIATE_FLONUMS + } else if (sexp_flonump(obj)) { + f = sexp_flonum_value(obj); + i = sprintf(numbuf, "%.15g", f); + if (f == trunc(f)) { + numbuf[i++] = '.'; numbuf[i++] = '0'; numbuf[i++] = '\0'; + } + sexp_write_string(ctx, numbuf, out); +#endif + } else if (sexp_charp(obj)) { + if (obj == sexp_make_character(' ')) + sexp_write_string(ctx, "#\\space", out); + else if (obj == sexp_make_character('\n')) + sexp_write_string(ctx, "#\\newline", out); + else if (obj == sexp_make_character('\r')) + sexp_write_string(ctx, "#\\return", out); + else if (obj == sexp_make_character('\t')) + sexp_write_string(ctx, "#\\tab", out); + else if ((33 <= sexp_unbox_character(obj)) + && (sexp_unbox_character(obj) < 127)) + sexp_write_char(ctx, sexp_unbox_character(obj), out); + else { + sexp_write_string(ctx, "#\\x", out); + sexp_write_char(ctx, hex_digit(sexp_unbox_character(obj)>>4), out); + sexp_write_char(ctx, hex_digit(sexp_unbox_character(obj)&0xF), out); + } + } 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 "opt/sexp-unhuff.c" + sexp_write_char(ctx, res, out); + } + } +#endif + + } else { + switch ((sexp_uint_t) obj) { + case (sexp_uint_t) SEXP_NULL: + sexp_write_string(ctx, "()", out); break; + case (sexp_uint_t) SEXP_TRUE: + sexp_write_string(ctx, "#t", out); break; + case (sexp_uint_t) SEXP_FALSE: + sexp_write_string(ctx, "#f", out); break; + case (sexp_uint_t) SEXP_EOF: + sexp_write_string(ctx, "#", out); break; + case (sexp_uint_t) SEXP_UNDEF: + case (sexp_uint_t) SEXP_VOID: + sexp_write_string(ctx, "#", out); break; + default: + sexp_write_string(ctx, "#", out); + } + } +} + +#define INIT_STRING_BUFFER_SIZE 128 + +sexp sexp_read_string(sexp ctx, sexp in) { + int c, i=0, size=INIT_STRING_BUFFER_SIZE; + char initbuf[INIT_STRING_BUFFER_SIZE]; + char *buf=initbuf, *tmp; + sexp res; + + for (c = sexp_read_char(ctx, in); c != '"'; c = sexp_read_char(ctx, in)) { + if (c == '\\') { + c = sexp_read_char(ctx, in); + switch (c) {case 'n': c = '\n'; break; case 't': c = '\t'; break;} + } + if (c == EOF) { + res = sexp_read_error(ctx, "premature end of string", SEXP_NULL, in); + break; + } + buf[i++] = c; + if (i >= size) { /* expand buffer w/ malloc(), later free() it */ + tmp = (char*) malloc(size*2); + memcpy(tmp, buf, i); + if (size != INIT_STRING_BUFFER_SIZE) free(buf); + buf = tmp; + size *= 2; + } + } + + buf[i] = '\0'; + res = sexp_c_string(ctx, buf, i); + if (size != INIT_STRING_BUFFER_SIZE) free(buf); + return res; +} + +sexp sexp_read_symbol(sexp ctx, sexp in, int init, int internp) { + int c, i=0, size=INIT_STRING_BUFFER_SIZE; + char initbuf[INIT_STRING_BUFFER_SIZE]; + char *buf=initbuf, *tmp; + sexp res; + + if (init != EOF) + buf[i++] = init; + + for (c = sexp_read_char(ctx, in); c != '"'; c = sexp_read_char(ctx, in)) { + if (c == '\\') c = sexp_read_char(ctx, in); + if (c == EOF || is_separator(c)) { + sexp_push_char(ctx, c, in); + break; + } + buf[i++] = c; + if (i >= size) { /* expand buffer w/ malloc(), later free() it */ + tmp = (char*) malloc(size*2); + memcpy(tmp, buf, i); + if (size != INIT_STRING_BUFFER_SIZE) free(buf); + buf = tmp; + size *= 2; + } + } + + buf[i] = '\0'; + res = (internp ? sexp_intern(ctx, buf) : sexp_c_string(ctx, buf, i)); + if (size != INIT_STRING_BUFFER_SIZE) free(buf); + return res; +} + +sexp sexp_read_float_tail(sexp ctx, sexp in, sexp_sint_t whole) { + sexp exponent; + double res=0.0, scale=0.1, e=0.0; + int c; + for (c=sexp_read_char(ctx, in); + isdigit(c); + c=sexp_read_char(ctx, in), scale*=0.1) + res += digit_value(c)*scale; + sexp_push_char(ctx, c, in); + if (c=='e' || c=='E') { + exponent = sexp_read_number(ctx, in, 10); + if (sexp_exceptionp(exponent)) return exponent; + e = (sexp_integerp(exponent) ? sexp_unbox_integer(exponent) + : sexp_flonump(exponent) ? sexp_flonum_value(exponent) : 0.0); + } else if ((c!=EOF) && ! is_separator(c)) + return sexp_read_error(ctx, "invalid numeric syntax", + sexp_make_character(c), in); + return sexp_make_flonum(ctx, (whole + res) * pow(10, e)); +} + +sexp sexp_read_number(sexp ctx, sexp in, int base) { + sexp f, den; + sexp_sint_t res = 0, negativep = 0, c; + + c = sexp_read_char(ctx, in); + if (c == '-') + negativep = 1; + else if (isdigit(c)) + res = digit_value(c); + + if (base == 16) + for (c=sexp_read_char(ctx, in); isxdigit(c); c=sexp_read_char(ctx, in)) + res = res * base + digit_value(c); + else + for (c=sexp_read_char(ctx, in); isdigit(c); c=sexp_read_char(ctx, in)) + res = res * base + digit_value(c); + + if (c=='.' || c=='e' || c=='E') { + if (base != 10) + return + sexp_read_error(ctx, "decimal found in non-base 10", SEXP_NULL, in); + if (c!='.') + sexp_push_char(ctx, c, in); + f = sexp_read_float_tail(ctx, in, res); + if (! sexp_flonump(f)) return f; + if ((c!='.') && (sexp_flonum_value(f) == round(sexp_flonum_value(f)))) { + res = (sexp_sint_t) sexp_flonum_value(f); + } else { + if (negativep) +#if USE_IMMEDIATE_FLONUMS + f = sexp_make_flonum(ctx, -sexp_flonum_value(f)); +#else + sexp_flonum_value(f) = -sexp_flonum_value(f); +#endif + return f; + } + } else if (c=='/') { + den = sexp_read_number(ctx, in, base); + if (! sexp_integerp(den)) + return (sexp_exceptionp(den) + ? den : sexp_read_error(ctx, "invalid rational syntax", den, in)); + return sexp_make_flonum(ctx, (double)(negativep ? -res : res) + / (double)sexp_unbox_integer(den)); + } else { + if ((c!=EOF) && ! is_separator(c)) + return sexp_read_error(ctx, "invalid numeric syntax", + sexp_make_character(c), in); + sexp_push_char(ctx, c, in); + } + + return sexp_make_integer(negativep ? -res : res); +} + +sexp sexp_read_raw (sexp ctx, sexp in) { + char *str; + int c1, c2, line; + sexp tmp2; + sexp_gc_var(ctx, res, s_res); + sexp_gc_var(ctx, tmp, s_tmp); + sexp_gc_preserve(ctx, res, s_res); + sexp_gc_preserve(ctx, tmp, s_tmp); + + scan_loop: + switch (c1 = sexp_read_char(ctx, in)) { + case EOF: + res = SEXP_EOF; + break; + case ';': + sexp_port_line(in)++; + while ((c1 = sexp_read_char(ctx, 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(ctx, in); + res = sexp_list2(ctx, the_quote_symbol, res); + break; + case '`': + res = sexp_read(ctx, in); + res = sexp_list2(ctx, the_quasiquote_symbol, res); + break; + case ',': + if ((c1 = sexp_read_char(ctx, in)) == '@') { + res = sexp_read(ctx, in); + res = sexp_list2(ctx, the_unquote_splicing_symbol, res); + } else { + sexp_push_char(ctx, c1, in); + res = sexp_read(ctx, in); + res = sexp_list2(ctx, the_unquote_symbol, res); + } + break; + case '"': + res = sexp_read_string(ctx, in); + break; + case '(': + line = (sexp_port_sourcep(in) ? sexp_port_line(in) : -1); + res = SEXP_NULL; + tmp = sexp_read_raw(ctx, in); + while ((tmp != SEXP_EOF) && (tmp != SEXP_CLOSE) && (tmp != SEXP_RAWDOT)) { + res = sexp_cons(ctx, tmp, res); + tmp = sexp_read_raw(ctx, in); + if (sexp_exceptionp(tmp)) { + res = tmp; + break; + } + } + if (! sexp_exceptionp(res)) { + if (tmp == SEXP_RAWDOT) { /* dotted list */ + if (res == SEXP_NULL) { + res = sexp_read_error(ctx, "dot before any elements in list", + SEXP_NULL, in); + } else { + tmp = sexp_read_raw(ctx, in); + if (sexp_exceptionp(tmp)) { + res = tmp; + } else if (tmp == SEXP_CLOSE) { + res = sexp_read_error(ctx, "no final element in list after dot", + SEXP_NULL, in); + } else if (sexp_read_raw(ctx, in) != SEXP_CLOSE) { + res = sexp_read_error(ctx, "multiple tokens in dotted tail", + SEXP_NULL, in); + } else { + tmp2 = res; + res = sexp_nreverse(ctx, res); + sexp_cdr(tmp2) = tmp; + } + } + } else if (tmp == SEXP_CLOSE) { + res = (sexp_pairp(res) ? sexp_nreverse(ctx, res) : res); + } else { + res = sexp_read_error(ctx, "missing trailing ')'", SEXP_NULL, in); + } + } + if ((line >= 0) && sexp_pairp(res)) + sexp_pair_source(res) + = sexp_cons(ctx, sexp_port_name(in), sexp_make_integer(line)); + break; + case '#': + switch (c1=sexp_read_char(ctx, in)) { + case 'b': + res = sexp_read_number(ctx, in, 2); break; + case 'o': + res = sexp_read_number(ctx, in, 8); break; + case 'd': + res = sexp_read_number(ctx, in, 10); break; + case 'x': + res = sexp_read_number(ctx, in, 16); break; + case 'e': + res = sexp_read(ctx, in); + if (sexp_flonump(res)) + res = sexp_make_integer((sexp_sint_t)sexp_flonum_value(res)); + break; + case 'i': + res = sexp_read(ctx, in); + if (sexp_integerp(res)) + res = sexp_make_flonum(ctx, sexp_unbox_integer(res)); + break; + case 'f': + case 't': + c2 = sexp_read_char(ctx, in); + if (c2 == EOF || is_separator(c2)) { + res = (c1 == 't' ? SEXP_TRUE : SEXP_FALSE); + sexp_push_char(ctx, c2, in); + } else { + tmp = sexp_list2(ctx, sexp_make_character(c1), sexp_make_character(c2)); + res = sexp_read_error(ctx, "invalid syntax #%c%c", tmp, in); + } + break; +/* case '0': case '1': case '2': case '3': case '4': */ +/* case '5': case '6': case '7': case '8': case '9': */ + case ';': + tmp = sexp_read_raw(ctx, in); /* discard */ + if (sexp_exceptionp(tmp)) + res = tmp; + else + goto scan_loop; + case '\\': + c1 = sexp_read_char(ctx, in); + res = sexp_read_symbol(ctx, in, c1, 0); + if (sexp_stringp(res)) { + str = sexp_string_data(res); + if (sexp_string_length(res) == 0) + res = + sexp_read_error(ctx, "unexpected end of character literal", + SEXP_NULL, in); + if (sexp_string_length(res) == 1) { + res = sexp_make_character(c1); + } else if ((c1 == 'x' || c1 == 'X') && + isxdigit(str[1]) && isxdigit(str[2]) && str[3] == '\0') { + res = sexp_make_character(16 * digit_value(str[1]) + + digit_value(str[2])); + } else { + if (strcasecmp(str, "space") == 0) + res = sexp_make_character(' '); + else if (strcasecmp(str, "newline") == 0) + res = sexp_make_character('\n'); + else if (strcasecmp(str, "return") == 0) + res = sexp_make_character('\r'); + else if (strcasecmp(str, "tab") == 0) + res = sexp_make_character('\t'); + else { + tmp = sexp_c_string(ctx, str, -1); + res = sexp_read_error(ctx, "unknown character name", tmp, in); + } + } + } + break; + case '(': + sexp_push_char(ctx, c1, in); + res = sexp_read(ctx, in); + if (sexp_not(sexp_listp(ctx, res))) { + if (! sexp_exceptionp(res)) { + res = sexp_read_error(ctx, "dotted list not allowed in vector syntax", + SEXP_NULL, + in); + } + } else { + res = sexp_list_to_vector(ctx, res); + } + break; + default: + res = sexp_read_error(ctx, "invalid # syntax", + sexp_make_character(c1), in); + } + break; + case '.': + c1 = sexp_read_char(ctx, in); + if (c1 == EOF || is_separator(c1)) { + res = SEXP_RAWDOT; + } else if (isdigit(c1)) { + sexp_push_char(ctx, c1, in); + res = sexp_read_float_tail(ctx, in, 0); + } else { + sexp_push_char(ctx, c1, in); + res = sexp_read_symbol(ctx, in, '.', 1); + } + break; + case ')': + res = SEXP_CLOSE; + break; + case '+': + case '-': + c2 = sexp_read_char(ctx, in); + if (c2 == '.' || isdigit(c2)) { + sexp_push_char(ctx, c2, in); + res = sexp_read_number(ctx, in, 10); + if ((c1 == '-') && ! sexp_exceptionp(res)) { +#if USE_FLONUMS + if (sexp_flonump(res)) +#if USE_IMMEDIATE_FLONUMS + res = sexp_make_flonum(ctx, -1 * sexp_flonum_value(res)); +#else + sexp_flonum_value(res) = -1 * sexp_flonum_value(res); +#endif + else +#endif + res = sexp_fx_mul(res, -1); + } + } else { + sexp_push_char(ctx, c2, in); + res = sexp_read_symbol(ctx, in, c1, 1); + } + break; + case '0': case '1': case '2': case '3': case '4': + case '5': case '6': case '7': case '8': case '9': + sexp_push_char(ctx, c1, in); + res = sexp_read_number(ctx, in, 10); + break; + default: + res = sexp_read_symbol(ctx, in, c1, 1); + break; + } + + sexp_gc_release(ctx, res, s_res); + return res; +} + +sexp sexp_read (sexp ctx, sexp in) { + sexp res = sexp_read_raw(ctx, in); + if (res == SEXP_CLOSE) + return sexp_read_error(ctx, "too many ')'s", SEXP_NULL, in); + if (res == SEXP_RAWDOT) + return sexp_read_error(ctx, "unexpected '.'", SEXP_NULL, in); + return res; +} + +sexp sexp_read_from_string(sexp ctx, char *str) { + sexp res; + sexp_gc_var(ctx, s, s_s); + sexp_gc_var(ctx, in, s_in); + sexp_gc_preserve(ctx, s, s_s); + sexp_gc_preserve(ctx, in, s_in); + s = sexp_c_string(ctx, str, -1); + in = sexp_make_input_string_port(ctx, s); + res = sexp_read(ctx, in); + sexp_gc_release(ctx, s, s_s); + return res; +} + +void sexp_init() { + int i; + sexp ctx; + if (! sexp_initialized_p) { + sexp_initialized_p = 1; +#if USE_BOEHM + GC_init(); + GC_add_roots((char*)&sexp_symbol_table, + ((char*)&sexp_symbol_table)+sizeof(sexp_symbol_table)+1); +#elif ! USE_MALLOC + sexp_gc_init(); +#endif + for (i=0; i 6 diff --git a/tests/basic/test00-fact-3.scm b/tests/basic/test00-fact-3.scm new file mode 100644 index 00000000..41d9c20e --- /dev/null +++ b/tests/basic/test00-fact-3.scm @@ -0,0 +1,14 @@ + +(define (fact-helper x res) + (if (= x 0) + res + (fact-helper (- x 1) (* res x)))) + +(define (fact x) + (fact-helper x 1)) + +(display "(fact 3) => ") +(write (fact 3)) +(newline) + + diff --git a/tests/basic/test01-apply.res b/tests/basic/test01-apply.res new file mode 100644 index 00000000..c5b83af4 --- /dev/null +++ b/tests/basic/test01-apply.res @@ -0,0 +1,8 @@ +11 +(11 10 9 8 7 6 5 4 3 2 1) +(1 2 3 4) +100 +100 +100 +100 +100 diff --git a/tests/basic/test01-apply.scm b/tests/basic/test01-apply.scm new file mode 100644 index 00000000..183a591c --- /dev/null +++ b/tests/basic/test01-apply.scm @@ -0,0 +1,18 @@ + +(define foo + (lambda (a b c d e f g h) + (+ (+ (* a b) (* c d)) (+ (* e f) (* g h))))) + +(define (writeln x) + (write x) + (newline)) + +(writeln (length (reverse (list 1 2 3 4 5 6 7 8 9 10 11)))) +(writeln (reverse (list 1 2 3 4 5 6 7 8 9 10 11))) +(writeln (append (list 1 2) (list 3 4))) +(writeln (foo 1 2 3 4 5 6 7 8)) +(writeln (apply foo (list 1 2 3 4 5 6 7 8))) +(writeln (apply foo 1 (list 2 3 4 5 6 7 8))) +(writeln (apply foo 1 2 3 4 (list 5 6 7 8))) +(writeln (apply foo 1 2 3 4 5 (list 6 7 8))) + diff --git a/tests/basic/test02-closure.res b/tests/basic/test02-closure.res new file mode 100644 index 00000000..4d764d20 --- /dev/null +++ b/tests/basic/test02-closure.res @@ -0,0 +1,6 @@ +1 +2 +101 +102 +3 +103 diff --git a/tests/basic/test02-closure.scm b/tests/basic/test02-closure.scm new file mode 100644 index 00000000..6ed987fe --- /dev/null +++ b/tests/basic/test02-closure.scm @@ -0,0 +1,16 @@ + +(define (make-counter n) + (lambda () + (set! n (+ n 1)) + n)) + +(define f (make-counter 0)) +(define g (make-counter 100)) + +(write (f)) (newline) +(write (f)) (newline) +(write (g)) (newline) +(write (g)) (newline) +(write (f)) (newline) +(write (g)) (newline) + diff --git a/tests/basic/test03-nested-closure.res b/tests/basic/test03-nested-closure.res new file mode 100644 index 00000000..c97c8394 --- /dev/null +++ b/tests/basic/test03-nested-closure.res @@ -0,0 +1 @@ +11357 diff --git a/tests/basic/test03-nested-closure.scm b/tests/basic/test03-nested-closure.scm new file mode 100644 index 00000000..6656bd4e --- /dev/null +++ b/tests/basic/test03-nested-closure.scm @@ -0,0 +1,8 @@ + +((lambda (a b) + ((lambda (c d e) + (write (+ e (* c 1000) (* a 100) (* b 10) d)) + (newline)) + (- a 2) (+ b 2) 10000)) + 3 5) + diff --git a/tests/basic/test04-nested-let.res b/tests/basic/test04-nested-let.res new file mode 100644 index 00000000..c97c8394 --- /dev/null +++ b/tests/basic/test04-nested-let.res @@ -0,0 +1 @@ +11357 diff --git a/tests/basic/test04-nested-let.scm b/tests/basic/test04-nested-let.scm new file mode 100644 index 00000000..584bc6e5 --- /dev/null +++ b/tests/basic/test04-nested-let.scm @@ -0,0 +1,9 @@ + +(let ((a 3) + (b 5)) + (let ((c (- a 2)) + (d (+ b 2)) + (e 10000)) + (write (+ e (* c 1000) (* a 100) (* b 10) d)) + (newline))) + diff --git a/tests/basic/test05-internal-define.res b/tests/basic/test05-internal-define.res new file mode 100644 index 00000000..4edae4cc --- /dev/null +++ b/tests/basic/test05-internal-define.res @@ -0,0 +1 @@ +1000 1003 diff --git a/tests/basic/test05-internal-define.scm b/tests/basic/test05-internal-define.scm new file mode 100644 index 00000000..a5576a63 --- /dev/null +++ b/tests/basic/test05-internal-define.scm @@ -0,0 +1,8 @@ + +(let ((a 1000)) + (define b (+ a 3)) + (write a) + (display " ") + (write b) + (newline)) + diff --git a/tests/basic/test06-letrec.res b/tests/basic/test06-letrec.res new file mode 100644 index 00000000..83d9c566 --- /dev/null +++ b/tests/basic/test06-letrec.res @@ -0,0 +1,4 @@ +7 +#t +#f +#f diff --git a/tests/basic/test06-letrec.scm b/tests/basic/test06-letrec.scm new file mode 100644 index 00000000..a9c01b4e --- /dev/null +++ b/tests/basic/test06-letrec.scm @@ -0,0 +1,15 @@ + +(letrec ((add (lambda (a b) (+ a b)))) + (write (add 3 4)) + (newline)) + +(letrec ((even? (lambda (n) (if (zero? n) #t (odd? (- n 1))))) + (odd? (lambda (n) (if (zero? n) #f (even? (- n 1)))))) + (write (even? 1000)) + (newline) + (write (even? 1001)) + (newline) + (write (odd? 1000)) + (newline) + ) + diff --git a/tests/basic/test07-mutation.res b/tests/basic/test07-mutation.res new file mode 100644 index 00000000..c97c8394 --- /dev/null +++ b/tests/basic/test07-mutation.res @@ -0,0 +1 @@ +11357 diff --git a/tests/basic/test07-mutation.scm b/tests/basic/test07-mutation.scm new file mode 100644 index 00000000..8dacb7fb --- /dev/null +++ b/tests/basic/test07-mutation.scm @@ -0,0 +1,9 @@ + +(let ((a 3) + (b 5)) + (let ((c (- a 2)) + (d (+ b 2)) + (e #f)) + (set! e 10000) + (write (+ e (* c 1000) (* a 100) (* b 10) d)) + (newline))) diff --git a/tests/basic/test08-callcc.res b/tests/basic/test08-callcc.res new file mode 100644 index 00000000..849baeed --- /dev/null +++ b/tests/basic/test08-callcc.res @@ -0,0 +1 @@ +543 diff --git a/tests/basic/test08-callcc.scm b/tests/basic/test08-callcc.scm new file mode 100644 index 00000000..3a5c355e --- /dev/null +++ b/tests/basic/test08-callcc.scm @@ -0,0 +1,34 @@ + +(define fail + (lambda () 999999)) + +(define in-range + (lambda (a b) + (call-with-current-continuation + (lambda (cont) + (enumerate a b cont))))) + +(define enumerate + (lambda (a b cont) + (if (< b a) + (fail) + (let ((save fail)) + (begin + (set! fail + (lambda () + (begin + (set! fail save) + (enumerate (+ a 1) b cont)))) + (cont a)))))) + +(write + (let ((x (in-range 2 9)) + (y (in-range 2 9)) + (z (in-range 2 9))) + (if (= (* x x) + (+ (* y y) (* z z))) + (+ (* x 100) (+ (* y 10) z)) + (fail)))) + +(newline) + diff --git a/tests/basic/test09-hygiene.res b/tests/basic/test09-hygiene.res new file mode 100644 index 00000000..31cd4d7e --- /dev/null +++ b/tests/basic/test09-hygiene.res @@ -0,0 +1,7 @@ +1 +2 +3 +4 +5 +6 +outer diff --git a/tests/basic/test09-hygiene.scm b/tests/basic/test09-hygiene.scm new file mode 100644 index 00000000..4ec53fe3 --- /dev/null +++ b/tests/basic/test09-hygiene.scm @@ -0,0 +1,62 @@ + +(write (or 1)) +(newline) +(write (or #f 2)) +(newline) +(write (or 3 #t)) +(newline) + +(let ((tmp 4)) + (write (or #f tmp)) + (newline)) + +(write + (letrec-syntax + ((myor + (er-macro-transformer + (lambda (expr rename compare) + (if (null? (cdr expr)) + #f + (list (rename 'let) (list (list (rename 'tmp) (cadr expr))) + (list (rename 'if) (rename 'tmp) + (rename 'tmp) + (cons (rename 'myor) (cddr expr))))))))) + (let ((tmp 5)) (myor #f tmp)))) +(newline) + +(define-syntax myor + (er-macro-transformer + (lambda (expr rename compare) + (if (null? (cdr expr)) + #f + (list (rename 'let) (list (list (rename 'tmp) (cadr expr))) + (list (rename 'if) (rename 'tmp) + (rename 'tmp) + (cons (rename 'myor) (cddr expr)))))))) + +(write (let ((tmp 6)) (myor #f tmp))) +(newline) + +;; (let ((x 'outer)) +;; (let-syntax ((with-x +;; (syntax-rules () +;; ((_ y expr) +;; (let-syntax ((y (syntax-rules () ((_) x)))) +;; expr))))) +;; (let ((x 'inner)) +;; (write (with-x z (z))) +;; (newline)))) + +(let ((x 'outer)) + (let-syntax ((with-x + (er-macro-transformer + (lambda (form rename compare) + `(let-syntax ((,(cadr form) + (er-macro-transformer + (lambda (form rename2 compare) + (rename2 'x))))) + ,(caddr form)))))) + (let ((x 'inner)) + (write (with-x z (z))) + (newline)))) + diff --git a/tests/basic/test10-unhygiene.res b/tests/basic/test10-unhygiene.res new file mode 100644 index 00000000..0d174dc4 --- /dev/null +++ b/tests/basic/test10-unhygiene.res @@ -0,0 +1,6 @@ +1 +1 +1 +6 +7 +8 diff --git a/tests/basic/test10-unhygiene.scm b/tests/basic/test10-unhygiene.scm new file mode 100644 index 00000000..c60a6bca --- /dev/null +++ b/tests/basic/test10-unhygiene.scm @@ -0,0 +1,49 @@ + +(define-syntax aif + (sc-macro-transformer + (lambda (form environment) + (let ((condition + (make-syntactic-closure environment '() (cadr form))) + (consequent + (make-syntactic-closure environment '(it) (caddr form))) + (alternative + (make-syntactic-closure environment '() (cadddr form)))) + `(let ((it ,condition)) + (if it + ,consequent + ,alternative)))))) + +(write (aif 1 it 3)) +(newline) + +(write (let ((it 4)) (aif 1 it 3))) +(newline) + +(write (let ((it 4)) (aif (let ((it 5)) 1) it 3))) +(newline) + +(write (let ((it 4)) (aif (let ((it 5)) 1) (let ((it 6)) it) 3))) +(newline) + +(write + (letrec-syntax + ((myor + (er-macro-transformer + (lambda (expr rename compare) + (if (null? (cdr expr)) + #f + (list (rename 'let) (list (list (rename 'it) (cadr expr))) + (list (rename 'if) (rename 'it) + (rename 'it) + (cons (rename 'myor) (cddr expr))))))))) + (let ((it 7)) (myor #f it)))) +(newline) + +(define-syntax define-foo + (sc-macro-transformer + (lambda (form environment) + (make-syntactic-closure environment '(foo) `(define foo 8))))) + +(define-foo) +(write foo) +(newline) diff --git a/tests/r5rs-tests.scm b/tests/r5rs-tests.scm new file mode 100644 index 00000000..8fc0606e --- /dev/null +++ b/tests/r5rs-tests.scm @@ -0,0 +1,377 @@ + +(define *tests-run* 0) +(define *tests-passed* 0) + +(define-syntax test + (syntax-rules () + ((test expect expr) + (begin + (set! *tests-run* (+ *tests-run* 1)) + (let ((str (call-with-output-string (lambda (out) (display 'expr out)))) + (res expr)) + (display str) + (write-char #\space) + (display (make-string (max 0 (- 72 (string-length str))) #\.)) + (flush-output) + (cond + ((equal? res expect) + (set! *tests-passed* (+ *tests-passed* 1)) + (display " [PASS]\n")) + (else + (display " [FAIL]\n") + (display " expected ") (write expect) + (display " but got ") (write res) (newline)))))))) + +(define (test-report) + (write *tests-passed*) + (display " out of ") + (write *tests-run*) + (display " passed (") + (write (* (/ *tests-passed* *tests-run*) 100)) + (display "%)") + (newline)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(test 8 ((lambda (x) (+ x x)) 4)) + +(test '(3 4 5 6) ((lambda x x) 3 4 5 6)) + +(test '(5 6) ((lambda (x y . z) z) 3 4 5 6)) + +(test 'yes (if (> 3 2) 'yes 'no)) + +(test 'no (if (> 2 3) 'yes 'no)) + +(test 1 (if (> 3 2) (- 3 2) (+ 3 2))) + +(test 'greater (cond ((> 3 2) 'greater) ((< 3 2) 'less))) + +(test 'equal (cond ((> 3 3) 'greater) ((< 3 3) 'less) (else 'equal))) + +(test 'composite (case (* 2 3) ((2 3 5 7) 'prime) ((1 4 6 8 9) 'composite))) + +(test 'consonant + (case (car '(c d)) + ((a e i o u) 'vowel) + ((w y) 'semivowel) + (else 'consonant))) + +(test #t (and (= 2 2) (> 2 1))) + +(test #f (and (= 2 2) (< 2 1))) + +(test '(f g) (and 1 2 'c '(f g))) + +(test #t (and)) + +(test #t (or (= 2 2) (> 2 1))) + +(test #t (or (= 2 2) (< 2 1))) + +(test '(b c) (or (memq 'b '(a b c)) (/ 3 0))) + +(test 6 (let ((x 2) (y 3)) (* x y))) + +(test 35 (let ((x 2) (y 3)) (let ((x 7) (z (+ x y))) (* z x)))) + +(test 70 (let ((x 2) (y 3)) (let* ((x 7) (z (+ x y))) (* z x)))) + +(test '#(0 1 2 3 4) + (do ((vec (make-vector 5)) + (i 0 (+ i 1))) + ((= i 5) vec) + (vector-set! vec i i))) + +(test 25 + (let ((x '(1 3 5 7 9))) + (do ((x x (cdr x)) + (sum 0 (+ sum (car x)))) + ((null? x) + sum)))) + +(test '((6 1 3) (-5 -2)) + (let loop ((numbers '(3 -2 1 6 -5)) (nonneg '()) (neg '())) + (cond + ((null? numbers) + (list nonneg neg)) + ((>= (car numbers) 0) + (loop (cdr numbers) (cons (car numbers) nonneg) neg)) + ((< (car numbers) 0) + (loop (cdr numbers) nonneg (cons (car numbers) neg)))))) + +(test '(list 3 4) `(list ,(+ 1 2) 4)) + +(test '(list a 'a) (let ((name 'a)) `(list ,name ',name))) + +(test '(a 3 4 5 6 b) + `(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b)) + +(test '(10 5 2 4 3 8) + `(10 5 ,(sqrt 4) ,@(map sqrt '(16 9)) 8)) + +(test '(a `(b ,(+ 1 2) ,(foo 4 d) e) f) + `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f)) + +(test '(a `(b ,x ,'y d) e) + (let ((name1 'x) + (name2 'y)) + `(a `(b ,,name1 ,',name2 d) e))) + +(test '(list 3 4) + (quasiquote (list (unquote (+ 1 2)) 4))) + +(test #t (eqv? 'a 'a)) + +(test #f (eqv? 'a 'b)) + +(test #t (eqv? '() '())) + +(test #f (eqv? (cons 1 2) (cons 1 2))) + +(test #f (eqv? (lambda () 1) (lambda () 2))) + +(test #t (let ((p (lambda (x) x))) (eqv? p p))) + +(test #t (eq? 'a 'a)) + +(test #f (eq? (list 'a) (list 'a))) + +(test #t (eq? '() '())) + +(test #t (eq? car car)) + +(test #t (let ((x '(a))) (eq? x x))) + +(test #t (let ((p (lambda (x) x))) (eq? p p))) + +(test #t (equal? 'a 'a)) + +(test #t (equal? '(a) '(a))) + +(test #t (equal? '(a (b) c) '(a (b) c))) + +(test #t (equal? "abc" "abc")) + +(test #t (equal? 2 2)) + +(test #t (equal? (make-vector 5 'a) (make-vector 5 'a))) + +(test 4 (max 3 4)) + +(test 4 (max 3.9 4)) + +(test 7 (+ 3 4)) + +(test 3 (+ 3)) + +(test 0 (+)) + +(test 4 (* 4)) + +(test 1 (*)) + +(test -1 (- 3 4)) + +(test -6 (- 3 4 5)) + +(test -3 (- 3)) + +(test 7 (abs -7)) + +(test 1 (modulo 13 4)) + +(test 1 (remainder 13 4)) + +(test 3 (modulo -13 4)) + +(test -1 (remainder -13 4)) + +(test -3 (modulo 13 -4)) + +(test 1 (remainder 13 -4)) + +(test -1 (modulo -13 -4)) + +(test -1 (remainder -13 -4)) + +(test 4 (gcd 32 -36)) + +(test 288 (lcm 32 -36)) + +(test -5 (floor -4.3)) + +(test -4 (ceiling -4.3)) + +(test -4 (truncate -4.3)) + +(test -4 (round -4.3)) + +(test 3 (floor 3.5)) + +(test 4 (ceiling 3.5)) + +(test 3 (truncate 3.5)) + +(test 4 (round 3.5)) + +(test 100 (string->number "100")) + +(test 256 (string->number "100" 16)) + +(test 100 (string->number "1e2")) + +(test #f (not 3)) + +(test #f (not (list 3))) + +(test #f (not '())) + +(test #f (not (list))) + +(test #f (not '())) + +(test #f (boolean? 0)) + +(test #f (boolean? '())) + +(test #t (pair? '(a . b))) + +(test #t (pair? '(a b c))) + +(test '(a) (cons 'a '())) + +(test '((a) b c d) (cons '(a) '(b c d))) + +(test '("a" b c) (cons "a" '(b c))) + +(test '(a . 3) (cons 'a 3)) + +(test '((a b) . c) (cons '(a b) 'c)) + +(test 'a (car '(a b c))) + +(test '(a) (car '((a) b c d))) + +(test 1 (car '(1 . 2))) + +(test '(b c d) (cdr '((a) b c d))) + +(test 2 (cdr '(1 . 2))) + +(test #t (list? '(a b c))) + +(test #t (list? '())) + +(test #f (list? '(a . b))) + +(test #f + (let ((x (list 'a))) + (set-cdr! x x) + (list? x))) + +(test '(a 7 c) (list 'a (+ 3 4) 'c)) + +(test '() (list)) + +(test 3 (length '(a b c))) + +(test 3 (length '(a (b) (c d e)))) + +(test 0 (length '())) + +(test '(x y) (append '(x) '(y))) + +(test '(a b c d) (append '(a) '(b c d))) + +(test '(a (b) (c)) (append '(a (b)) '((c)))) + +(test '(a b c . d) (append '(a b) '(c . d))) + +(test 'a (append '() 'a)) + +(test '(c b a) (reverse '(a b c))) + +(test '((e (f)) d (b c) a) (reverse '(a (b c) d (e (f))))) + +(test 'c (list-ref '(a b c d) 2)) + +(test '(a b c) (memq 'a '(a b c))) + +(test '(b c) (memq 'b '(a b c))) + +(test #f (memq 'a '(b c d))) + +(test #f (memq (list 'a) '(b (a) c))) + +(test '((a) c) (member (list 'a) '(b (a) c))) + +(test '(101 102) (memv 101 '(100 101 102))) + +(test #f (assq (list 'a) '(((a)) ((b)) ((c))))) + +(test '((a)) (assoc (list 'a) '(((a)) ((b)) ((c))))) + +(test '(5 7) (assv 5 '((2 3) (5 7) (11 13)))) + +(test #t (symbol? 'foo)) + +(test #t (symbol? (car '(a b)))) + +(test #f (symbol? "bar")) + +(test #t (symbol? 'nil)) + +(test #f (symbol? '())) + +(test "flying-fish" (symbol->string 'flying-fish)) + +(test "Martin" (symbol->string 'Martin)) + +(test "Malvina" (symbol->string (string->symbol "Malvina"))) + +(test '#(0 ("Sue" "Sue") "Anna") + (let ((vec (vector 0 '(2 2 2 2) "Anna"))) + (vector-set! vec 1 '("Sue" "Sue")) + vec)) + +(test '(dah dah didah) (vector->list '#(dah dah didah))) + +(test '#(dididit dah) (list->vector '(dididit dah))) + +(test #t (procedure? car)) + +(test #f (procedure? 'car)) + +(test #t (procedure? (lambda (x) (* x x)))) + +(test #f (procedure? '(lambda (x) (* x x)))) + +(test #t (call-with-current-continuation procedure?)) + +(test 7 (apply + (list 3 4))) + +(test '(b e h) (map cadr '((a b) (d e) (g h)))) + +(test '(1 4 27 256 3125) (map (lambda (n) (expt n n)) '(1 2 3 4 5))) + +(test '(5 7 9) (map + '(1 2 3) '(4 5 6))) + +(test '#(0 1 4 9 16) + (let ((v (make-vector 5))) + (for-each + (lambda (i) (vector-set! v i (* i i))) + '(0 1 2 3 4)) + v)) + +(test 3 (force (delay (+ 1 2)))) + +(test '(3 3) (let ((p (delay (+ 1 2)))) (list (force p) (force p)))) + +(test 7 (call-with-current-continuation (lambda (k) (+ 2 5)))) + +(test 3 (call-with-current-continuation (lambda (k) (+ 2 5 (k 3))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(test-report) From 78ceffdee4906089a706d4e163ff20ac5e52770f Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 28 Jun 2009 19:07:19 +0900 Subject: [PATCH 151/154] making literals immutable --- eval.c | 12 ++++++++++++ include/chibi/sexp.h | 1 + sexp.c | 13 ++++++++++--- 3 files changed, 23 insertions(+), 3 deletions(-) diff --git a/eval.c b/eval.c index 871feb9d..7e599d5d 100644 --- a/eval.c +++ b/eval.c @@ -331,6 +331,7 @@ static sexp sexp_strip_synclos (sexp ctx, sexp x) { kar = sexp_strip_synclos(ctx, sexp_car(x)); kdr = sexp_strip_synclos(ctx, sexp_cdr(x)); res = sexp_cons(ctx, kar, kdr); + sexp_immutablep(res) = sexp_immutablep(x); } else { res = x; } @@ -1497,6 +1498,8 @@ sexp sexp_vm (sexp ctx, sexp proc) { case OP_VECTOR_SET: if (! sexp_vectorp(_ARG1)) sexp_raise("vector-set!: not a vector", sexp_list1(ctx, _ARG1)); + else if (sexp_immutablep(_ARG1)) + sexp_raise("vector-set!: immutable vector", sexp_list1(ctx, _ARG1)); sexp_vector_set(_ARG1, _ARG2, _ARG3); _ARG3 = SEXP_VOID; top-=2; @@ -1509,6 +1512,11 @@ sexp sexp_vm (sexp ctx, sexp proc) { top--; break; case OP_STRING_SET: + if (! sexp_stringp(_ARG1)) + sexp_raise("string-set!: not a string", sexp_list1(ctx, _ARG1)); + else if (sexp_immutablep(_ARG1)) + sexp_raise("string-set!: immutable string", sexp_list1(ctx, _ARG1)); + fprintf(stderr, "string-set! %p (immutable: %d)\n", _ARG1, sexp_immutablep(_ARG1)); sexp_string_set(_ARG1, _ARG2, _ARG3); _ARG3 = SEXP_VOID; top-=2; @@ -1557,6 +1565,8 @@ sexp sexp_vm (sexp ctx, sexp proc) { case OP_SET_CAR: if (! sexp_pairp(_ARG1)) sexp_raise("set-car!: not a pair", sexp_list1(ctx, _ARG1)); + else if (sexp_immutablep(_ARG1)) + sexp_raise("set-car!: immutable pair", sexp_list1(ctx, _ARG1)); sexp_car(_ARG1) = _ARG2; _ARG2 = SEXP_VOID; top--; @@ -1564,6 +1574,8 @@ sexp sexp_vm (sexp ctx, sexp proc) { case OP_SET_CDR: if (! sexp_pairp(_ARG1)) sexp_raise("set-cdr!: not a pair", sexp_list1(ctx, _ARG1)); + else if (sexp_immutablep(_ARG1)) + sexp_raise("set-cdr!: immutable pair", sexp_list1(ctx, _ARG1)); sexp_cdr(_ARG1) = _ARG2; _ARG2 = SEXP_VOID; top--; diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 8ab96d98..d1538cf2 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -286,6 +286,7 @@ void *sexp_realloc(sexp ctx, sexp x, size_t size); #define sexp_pointer_tag(x) ((x)->tag) #define sexp_gc_mark(x) ((x)->gc_mark) +#define sexp_immutablep(x) ((x)->immutablep) #define sexp_check_tag(x,t) (sexp_pointerp(x) && (sexp_pointer_tag(x) == (t))) diff --git a/sexp.c b/sexp.c index 9b909936..7d1d12d9 100644 --- a/sexp.c +++ b/sexp.c @@ -894,9 +894,10 @@ void sexp_write (sexp ctx, sexp obj, sexp out) { else if (obj == sexp_make_character('\t')) sexp_write_string(ctx, "#\\tab", out); else if ((33 <= sexp_unbox_character(obj)) - && (sexp_unbox_character(obj) < 127)) + && (sexp_unbox_character(obj) < 127)) { + sexp_write_string(ctx, "#\\", out); sexp_write_char(ctx, sexp_unbox_character(obj), out); - else { + } else { sexp_write_string(ctx, "#\\x", out); sexp_write_char(ctx, hex_digit(sexp_unbox_character(obj)>>4), out); sexp_write_char(ctx, hex_digit(sexp_unbox_character(obj)&0xF), out); @@ -1156,9 +1157,13 @@ sexp sexp_read_raw (sexp ctx, sexp in) { res = sexp_read_error(ctx, "missing trailing ')'", SEXP_NULL, in); } } - if ((line >= 0) && sexp_pairp(res)) + if ((line >= 0) && sexp_pairp(res)) { sexp_pair_source(res) = sexp_cons(ctx, sexp_port_name(in), sexp_make_integer(line)); + } + if (sexp_port_sourcep(in)) + for (tmp=res; sexp_pairp(tmp); tmp=sexp_cdr(tmp)) + sexp_immutablep(tmp) = 1; break; case '#': switch (c1=sexp_read_char(ctx, in)) { @@ -1296,6 +1301,8 @@ sexp sexp_read_raw (sexp ctx, sexp in) { break; } + if (sexp_port_sourcep(in) && sexp_pointerp(res)) + sexp_immutablep(res) = 1; sexp_gc_release(ctx, res, s_res); return res; } From 55a8a38e6232c1946c7a635d20b9a2cfcd55e9d2 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 30 Jun 2009 11:38:05 +0900 Subject: [PATCH 152/154] DESTDIR patch from sladegen --- .hgignore | 20 + Makefile | 118 ++ README | 52 + VERSION | 1 + debug.c | 75 + eval.c | 2199 ++++++++++++++++++++++++ gc.c | 237 +++ include/chibi/config.h | 120 ++ include/chibi/eval.h | 140 ++ include/chibi/sexp.h | 595 +++++++ init.scm | 713 ++++++++ main.c | 147 ++ mkfile | 36 + opcodes.c | 129 ++ opt/sexp-huff.c | 128 ++ opt/sexp-hufftabs.c | 92 + opt/sexp-unhuff.c | 71 + sexp.c | 1357 +++++++++++++++ tests/basic/test00-fact-3.res | 1 + tests/basic/test00-fact-3.scm | 14 + tests/basic/test01-apply.res | 8 + tests/basic/test01-apply.scm | 18 + tests/basic/test02-closure.res | 6 + tests/basic/test02-closure.scm | 16 + tests/basic/test03-nested-closure.res | 1 + tests/basic/test03-nested-closure.scm | 8 + tests/basic/test04-nested-let.res | 1 + tests/basic/test04-nested-let.scm | 9 + tests/basic/test05-internal-define.res | 1 + tests/basic/test05-internal-define.scm | 8 + tests/basic/test06-letrec.res | 4 + tests/basic/test06-letrec.scm | 15 + tests/basic/test07-mutation.res | 1 + tests/basic/test07-mutation.scm | 9 + tests/basic/test08-callcc.res | 1 + tests/basic/test08-callcc.scm | 34 + tests/basic/test09-hygiene.res | 7 + tests/basic/test09-hygiene.scm | 62 + tests/basic/test10-unhygiene.res | 6 + tests/basic/test10-unhygiene.scm | 49 + tests/r5rs-tests.scm | 377 ++++ 41 files changed, 6886 insertions(+) create mode 100644 .hgignore create mode 100644 Makefile create mode 100644 README create mode 100644 VERSION create mode 100644 debug.c create mode 100644 eval.c create mode 100644 gc.c create mode 100644 include/chibi/config.h create mode 100644 include/chibi/eval.h create mode 100644 include/chibi/sexp.h create mode 100644 init.scm create mode 100644 main.c create mode 100644 mkfile create mode 100644 opcodes.c create mode 100644 opt/sexp-huff.c create mode 100644 opt/sexp-hufftabs.c create mode 100644 opt/sexp-unhuff.c create mode 100644 sexp.c create mode 100644 tests/basic/test00-fact-3.res create mode 100644 tests/basic/test00-fact-3.scm create mode 100644 tests/basic/test01-apply.res create mode 100644 tests/basic/test01-apply.scm create mode 100644 tests/basic/test02-closure.res create mode 100644 tests/basic/test02-closure.scm create mode 100644 tests/basic/test03-nested-closure.res create mode 100644 tests/basic/test03-nested-closure.scm create mode 100644 tests/basic/test04-nested-let.res create mode 100644 tests/basic/test04-nested-let.scm create mode 100644 tests/basic/test05-internal-define.res create mode 100644 tests/basic/test05-internal-define.scm create mode 100644 tests/basic/test06-letrec.res create mode 100644 tests/basic/test06-letrec.scm create mode 100644 tests/basic/test07-mutation.res create mode 100644 tests/basic/test07-mutation.scm create mode 100644 tests/basic/test08-callcc.res create mode 100644 tests/basic/test08-callcc.scm create mode 100644 tests/basic/test09-hygiene.res create mode 100644 tests/basic/test09-hygiene.scm create mode 100644 tests/basic/test10-unhygiene.res create mode 100644 tests/basic/test10-unhygiene.scm create mode 100644 tests/r5rs-tests.scm diff --git a/.hgignore b/.hgignore new file mode 100644 index 00000000..9d217d26 --- /dev/null +++ b/.hgignore @@ -0,0 +1,20 @@ +syntax: glob +*~ +*.i +*.s +*.o +*.so +*.dylib +*.dSYM +*.orig +.hg +junk* +*.tar.gz +*.tar.bz2 +*.log +*.err +*.out +gc +gc6.8 +chibi-scheme +include/chibi/install.h diff --git a/Makefile b/Makefile new file mode 100644 index 00000000..3c4ada43 --- /dev/null +++ b/Makefile @@ -0,0 +1,118 @@ +# -*- makefile-gmake -*- + +.PHONY: all doc dist clean cleaner test install uninstall + +all: chibi-scheme + +CC ?= cc +PREFIX ?= /usr/local +BINDIR ?= $(PREFIX)/bin +LIBDIR ?= $(PREFIX)/lib +INCDIR ?= $(PREFIX)/include/chibi +MODDIR ?= $(PREFIX)/share/chibi + +DESTDIR ?= + +ifndef PLATFORM +ifeq ($(shell uname),Darwin) +PLATFORM=macosx +else +PLATFORM=unix +endif +endif + +ifeq ($(PLATFORM),macosx) +SO = .dylib +EXE = +CLIBFLAGS = -dynamiclib +STATICFLAGS = -static-libgcc +else +ifeq ($(PLATFORM),mingw) +SO = .dll +EXE = .exe +CLIBFLAGS = -fPIC -shared +else +SO = .so +EXE = +CLIBFLAGS = -fPIC -shared +STATICFLAGS = -static +endif +endif + +ifdef USE_BOEHM +GCLDFLAGS := -lgc +XCPPFLAGS := $(CPPFLAGS) -Iinclude -DUSE_BOEHM=1 +else +GCLDFLAGS := +XCPPFLAGS := $(CPPFLAGS) -Iinclude +endif + +XLDFLAGS := $(LDFLAGS) $(GCLDFLAGS) -lm +XCFLAGS := -Wall -g $(CFLAGS) + +INCLUDES = include/chibi/sexp.h include/chibi/config.h include/chibi/install.h + +include/chibi/install.h: Makefile + echo '#define sexp_module_dir "'$(MODDIR)'"' > $@ + +sexp.o: sexp.c gc.c $(INCLUDES) Makefile + $(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -o $@ $< + +eval.o: eval.c debug.c opcodes.c include/chibi/eval.h $(INCLUDES) Makefile + $(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -o $@ $< + +main.o: main.c $(INCLUDES) Makefile + $(CC) -c $(XCPPFLAGS) $(XCFLAGS) -o $@ $< + +libchibi-scheme$(SO): eval.o sexp.o + $(CC) $(CLIBFLAGS) -o $@ $^ $(XLDFLAGS) + +chibi-scheme$(EXE): main.o libchibi-scheme$(SO) + $(CC) $(XCPPFLAGS) $(XCFLAGS) -o $@ $< -L. -lchibi-scheme + +chibi-scheme-static$(EXE): main.o eval.o sexp.o + $(CC) $(XCFLAGS) $(STATICFLAGS) -o $@ $^ $(XLDFLAGS) + +clean: + rm -f *.o *.i *.s + +cleaner: clean + rm -f chibi-scheme chibi-scheme-static *$(SO) + rm -rf *.dSYM + +test-basic: chibi-scheme + @for f in tests/basic/*.scm; do \ + ./chibi-scheme $$f >$${f%.scm}.out 2>$${f%.scm}.err; \ + if diff -q $${f%.scm}.out $${f%.scm}.res; then \ + echo "[PASS] $${f%.scm}"; \ + else \ + echo "[FAIL] $${f%.scm}"; \ + fi; \ + done + +test: chibi-scheme + ./chibi-scheme tests/r5rs-tests.scm + +install: chibi-scheme + mkdir -p $(DESTDIR)$(BINDIR) + cp chibi-scheme $(DESTDIR)$(BINDIR)/ + mkdir -p $(DESTDIR)$(MODDIR) + cp init.scm $(DESTDIR)$(MODDIR)/ + mkdir -p $(DESTDIR)$(INCDIR) + cp $(INCLUDES) include/chibi/eval.h $(DESTDIR)$(INCDIR)/ + mkdir -p $(DESTDIR)$(LIBDIR) + cp libchibi-scheme$(SO) $(DESTDIR)$(LIBDIR)/ + if type ldconfig >/dev/null 2>/dev/null; then ldconfig; fi + +uninstall: + rm -f $(BINDIR)/chibi-scheme* + rm -f $(LIBDIR)/libchibi-scheme$(SO) + cd $(INCDIR) && rm -f $(INCLUDES) include/chibi/eval.h + rm -f $(MODDIR)/*.scm + +dist: cleaner + rm -f chibi-scheme-`cat VERSION`.tgz + mkdir chibi-scheme-`cat VERSION` + for f in `hg manifest`; do mkdir -p chibi-scheme-`cat VERSION`/`dirname $$f`; ln -s `pwd`/$$f chibi-scheme-`cat VERSION`/$$f; done + tar cphzvf chibi-scheme-`cat VERSION`.tgz chibi-scheme-`cat VERSION` + rm -rf chibi-scheme-`cat VERSION` diff --git a/README b/README new file mode 100644 index 00000000..bfd07571 --- /dev/null +++ b/README @@ -0,0 +1,52 @@ + + Chibi-Scheme + -------------- + + Minimal Scheme Implementation for use as an Extension Language + + http://synthcode.com/wiki/chibi-scheme/ + + +Chibi-Scheme is a very small but mostly complete R5RS Scheme +implementation using a reasonably fast custom VM. Chibi-Scheme tries +as much as possible not to trade its small size by cutting corners, +and provides full continuations, both low and high-level hygienic +macros based on syntactic-closures, string ports and exceptions. +Chibi-Scheme is written in highly portable C and supports multiple +simultaneous VM instances to run. + +To build, just run "make". This will provide a shared library +"libchibi-scheme", as well as a sample "chibi-scheme" command-line +repl. The "chibi-scheme-static" make target builds an equivalent +static executable. + +You can edit the file config.h for a number of settings, mostly +disabling features to make the executable smaller. You can specify +standard options directly as arguments to make, for example + + make CFLAGS=-Os + +to optimize for size, or + + make LDFLAGS=-L/usr/local/lib CPPFLAGS=-I/usr/local/include + +to compile against a library installed in /usr/local. + +By default Chibi uses a custom, precise, non-moving GC. You can link +against the Boehm conservative GC by editing the config file, or +directly from make with: + + make USE_BOEHM=1 + +See the file main.c for an example of using chibi-scheme as a library. +The essential functions to remember are: + + sexp_make_context(NULL, NULL, NULL) + returns a new context + + sexp_eval(context, expr) + evaluates an s-expression + + sexp_eval_string(context, str) + reads an s-expression from str and evaluates it + diff --git a/VERSION b/VERSION new file mode 100644 index 00000000..3b04cfb6 --- /dev/null +++ b/VERSION @@ -0,0 +1 @@ +0.2 diff --git a/debug.c b/debug.c new file mode 100644 index 00000000..d8a51689 --- /dev/null +++ b/debug.c @@ -0,0 +1,75 @@ +/* debug.c -- optional debugging utilities */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +static const char* reverse_opcode_names[] = + {"NOOP", "RAISE", "RESUMECC", "CALLCC", "APPLY1", "TAIL-CALL", "CALL", + "FCALL0", "FCALL1", "FCALL2", "FCALL3", "FCALL4", "FCALL5", "FCALL6", + "EVAL", "JUMP-UNLESS", + "JUMP", "PUSH", "DROP", "GLOBAL-REF", "GLOBAL-KNOWN-REF", "STACK-REF", + "LOCAL-REF", "LOCAL-SET", + "CLOSURE-REF", "VECTOR-REF", "VECTOR-SET", "VECTOR-LENGTH", "STRING-REF", + "STRING-SET", "STRING-LENGTH", "MAKE-PROCEDURE", "MAKE-VECTOR", "AND", + "NULL?", "FIXNUM?", "SYMBOL?", "CHAR?", + "EOF?", "TYPEP", "CAR", "CDR", "SET-CAR", "SET-CDR", "CONS", "ADD", "SUB", + "MUL", "DIV", "QUOTIENT", "REMAINDER", "NEGATIVE", "INVERSE", + "LT", "LE", "EQN", "EQ", + "EXACT->INEXACT", "INEXACT->EXACT", + "CHAR->INTEGER", "INTEGER->CHAR", "CHAR-UPCASE", "CHAR-DOWNCASE", + "DISPLAY", "WRITE", "WRITE-CHAR", + "NEWLINE", "FLUSH-OUTPUT", "READ", "READ-CHAR", "PEEK-CHAR", "RET", "DONE", + }; + +static sexp sexp_disasm (sexp ctx, sexp bc, sexp out) { + unsigned char *ip, opcode; + if (sexp_procedurep(bc)) + bc = sexp_procedure_code(bc); + ip = sexp_bytecode_data(bc); + loop: + opcode = *ip++; + if (opcode*sizeof(char*) < sizeof(reverse_opcode_names)) { + sexp_printf(ctx, out, " %s ", reverse_opcode_names[opcode]); + } else { + sexp_printf(ctx, out, " %d ", opcode); + } + switch (opcode) { + case OP_STACK_REF: + case OP_LOCAL_REF: + case OP_LOCAL_SET: + case OP_CLOSURE_REF: + case OP_JUMP: + case OP_JUMP_UNLESS: + case OP_FCALL0: + case OP_FCALL1: + case OP_FCALL2: + case OP_FCALL3: + case OP_TYPEP: + sexp_printf(ctx, out, "%ld", (sexp_sint_t) ((sexp*)ip)[0]); + ip += sizeof(sexp); + break; + case OP_GLOBAL_REF: + case OP_GLOBAL_KNOWN_REF: + case OP_TAIL_CALL: + case OP_CALL: + case OP_PUSH: + sexp_write(ctx, ((sexp*)ip)[0], out); + ip += sizeof(sexp); + break; + } + sexp_write_char(ctx, '\n', out); + if (ip - sexp_bytecode_data(bc) < sexp_bytecode_length(bc)) + goto loop; + return SEXP_VOID; +} + +#ifdef DEBUG_VM +static void sexp_print_stack (sexp *stack, int top, int fp, sexp out) { + int i; + for (i=0; i sexp_opcode_num_args(op)) + && (! sexp_opcode_variadic_p(op))) { + res = sexp_compile_error(ctx, "too many args for opcode", x); + } else { + res = analyze_app(ctx, sexp_cdr(x)); + if (! sexp_exceptionp(res)) + sexp_push(ctx, res, op); + } + } else { + res = analyze_app(ctx, x); + } + } + } else if (sexp_truep(sexp_listp(ctx, sexp_car(x))) + || (sexp_synclop(sexp_car(x)) + && sexp_truep(sexp_listp(ctx, + sexp_synclo_expr(sexp_car(x)))))) { + res = analyze_app(ctx, x); + } else { + res = sexp_compile_error(ctx, "invalid operand in application", x); + } + } else if (sexp_idp(x)) { + res = analyze_var_ref(ctx, x); + } else if (sexp_synclop(x)) { + ctx = sexp_make_child_context(ctx, sexp_context_lambda(ctx)); + sexp_context_env(ctx) = sexp_synclo_env(x); + sexp_context_fv(ctx) = sexp_append2(ctx, + sexp_synclo_free_vars(x), + sexp_context_fv(ctx)); + x = sexp_synclo_expr(x); + goto loop; + } else { + res = x; + } + sexp_gc_release(ctx, res, s_res); + return res; +} + +static sexp_sint_t sexp_context_make_label (sexp ctx) { + sexp_sint_t label = sexp_context_pos(ctx); + sexp_context_pos(ctx) += sizeof(sexp_uint_t); + return label; +} + +static void sexp_context_patch_label (sexp ctx, sexp_sint_t label) { + sexp bc = sexp_context_bc(ctx); + unsigned char *data = sexp_bytecode_data(bc)+label; + *((sexp_sint_t*)data) = sexp_context_pos(ctx)-label; +} + +static sexp finalize_bytecode (sexp ctx) { + emit(ctx, OP_RET); + shrink_bcode(ctx, sexp_context_pos(ctx)); + return sexp_context_bc(ctx); +} + +static void generate_lit (sexp ctx, sexp value) { + emit_push(ctx, value); +} + +static void generate_seq (sexp ctx, sexp app) { + sexp head=app, tail=sexp_cdr(app); + sexp_uint_t tailp = sexp_context_tailp(ctx); + sexp_context_tailp(ctx) = 0; + for ( ; sexp_pairp(tail); head=tail, tail=sexp_cdr(tail)) + if (sexp_pointerp(sexp_car(head)) && (! sexp_litp(sexp_car(head)))) { + generate(ctx, sexp_car(head)); + emit(ctx, OP_DROP); + sexp_context_depth(ctx)--; + } + sexp_context_tailp(ctx) = tailp; + generate(ctx, sexp_car(head)); +} + +static void generate_cnd (sexp ctx, sexp cnd) { + sexp_sint_t label1, label2, tailp=sexp_context_tailp(ctx); + sexp_context_tailp(ctx) = 0; + generate(ctx, sexp_cnd_test(cnd)); + sexp_context_tailp(ctx) = tailp; + emit(ctx, OP_JUMP_UNLESS); + sexp_context_depth(ctx)--; + label1 = sexp_context_make_label(ctx); + generate(ctx, sexp_cnd_pass(cnd)); + emit(ctx, OP_JUMP); + sexp_context_depth(ctx)--; + label2 = sexp_context_make_label(ctx); + sexp_context_patch_label(ctx, label1); + generate(ctx, sexp_cnd_fail(cnd)); + sexp_context_patch_label(ctx, label2); +} + +static void generate_non_global_ref (sexp ctx, sexp name, sexp cell, + sexp lambda, sexp fv, int unboxp) { + sexp_uint_t i; + sexp loc = sexp_cdr(cell); + if (loc == lambda && sexp_lambdap(lambda)) { + /* local ref */ + emit(ctx, OP_LOCAL_REF); + emit_word(ctx, sexp_param_index(lambda, name)); + } else { + /* closure ref */ + for (i=0; sexp_pairp(fv); fv=sexp_cdr(fv), i++) + if ((name == sexp_ref_name(sexp_car(fv))) + && (loc == sexp_ref_loc(sexp_car(fv)))) + break; + emit(ctx, OP_CLOSURE_REF); + emit_word(ctx, i); + } + if (unboxp && (sexp_memq(ctx, name, sexp_lambda_sv(loc)) != SEXP_FALSE)) + emit(ctx, OP_CDR); + sexp_context_depth(ctx)++; +} + +static void generate_ref (sexp ctx, sexp ref, int unboxp) { + sexp lam; + if (! sexp_lambdap(sexp_ref_loc(ref))) { + /* global ref */ + if (unboxp) { + emit(ctx, + (sexp_cdr(sexp_ref_cell(ref)) == SEXP_UNDEF) + ? OP_GLOBAL_REF : OP_GLOBAL_KNOWN_REF); + emit_word(ctx, (sexp_uint_t)sexp_ref_cell(ref)); + } else + emit_push(ctx, sexp_ref_cell(ref)); + } else { + lam = sexp_context_lambda(ctx); + generate_non_global_ref(ctx, sexp_ref_name(ref), sexp_ref_cell(ref), + lam, sexp_lambda_fv(lam), unboxp); + } +} + +static void generate_set (sexp ctx, sexp set) { + sexp ref = sexp_set_var(set), lambda; + /* compile the value */ + sexp_context_tailp(ctx) = 0; + if (sexp_lambdap(sexp_set_value(set))) + sexp_lambda_name(sexp_set_value(set)) = sexp_ref_name(ref); + generate(ctx, sexp_set_value(set)); + if (! sexp_lambdap(sexp_ref_loc(ref))) { + /* global vars are set directly */ + emit_push(ctx, sexp_ref_cell(ref)); + emit(ctx, OP_SET_CDR); + } else { + lambda = sexp_ref_loc(ref); + if (sexp_memq(ctx, sexp_ref_name(ref), sexp_lambda_sv(lambda)) + != SEXP_FALSE) { + /* stack or closure mutable vars are boxed */ + generate_ref(ctx, ref, 0); + emit(ctx, OP_SET_CDR); + } else { + /* internally defined variable */ + emit(ctx, OP_LOCAL_SET); + emit_word(ctx, sexp_param_index(lambda, sexp_ref_name(ref))); + } + } + sexp_context_depth(ctx)--; +} + +static void generate_opcode_app (sexp ctx, sexp app) { + sexp op = sexp_car(app); + sexp_sint_t i, num_args; + sexp_gc_var(ctx, ls, s_ls); + sexp_gc_preserve(ctx, ls, s_ls); + + num_args = sexp_unbox_integer(sexp_length(ctx, sexp_cdr(app))); + sexp_context_tailp(ctx) = 0; + + /* maybe push the default for an optional argument */ + if ((num_args == sexp_opcode_num_args(op)) + && sexp_opcode_variadic_p(op) + && sexp_opcode_default(op) + && (sexp_opcode_class(op) != OPC_PARAMETER)) { + emit_push(ctx, sexp_opcode_default(op)); + if (sexp_opcode_opt_param_p(op)) + emit(ctx, OP_CDR); + sexp_context_depth(ctx)++; + num_args++; + } + + /* push the arguments onto the stack */ + ls = ((sexp_opcode_inverse(op) + && (sexp_opcode_class(op) != OPC_ARITHMETIC_INV)) + ? sexp_cdr(app) : sexp_reverse(ctx, sexp_cdr(app))); + for ( ; sexp_pairp(ls); ls = sexp_cdr(ls)) + generate(ctx, sexp_car(ls)); + + /* emit the actual operator call */ + switch (sexp_opcode_class(op)) { + case OPC_ARITHMETIC: + if (num_args > 1) + emit(ctx, sexp_opcode_code(op)); + break; + case OPC_ARITHMETIC_INV: + emit(ctx, (num_args==1) ? sexp_opcode_inverse(op) : sexp_opcode_code(op)); + break; + case OPC_ARITHMETIC_CMP: + if (num_args > 2) { + emit(ctx, OP_STACK_REF); + emit_word(ctx, 2); + emit(ctx, OP_STACK_REF); + emit_word(ctx, 2); + emit(ctx, sexp_opcode_code(op)); + emit(ctx, OP_AND); + for (i=num_args-2; i>0; i--) { + emit(ctx, OP_STACK_REF); + emit_word(ctx, 3); + emit(ctx, OP_STACK_REF); + emit_word(ctx, 3); + emit(ctx, sexp_opcode_code(op)); + emit(ctx, OP_AND); + emit(ctx, OP_AND); + } + } else + emit(ctx, sexp_opcode_code(op)); + break; + case OPC_FOREIGN: + case OPC_TYPE_PREDICATE: + /* push the funtion pointer for foreign calls */ + emit(ctx, sexp_opcode_code(op)); + if (sexp_opcode_data(op)) + emit_word(ctx, (sexp_uint_t)sexp_opcode_data(op)); + break; + case OPC_PARAMETER: + emit_push(ctx, sexp_opcode_default(op)); + emit(ctx, ((num_args == 0) ? OP_CDR : OP_SET_CDR)); + break; + default: + emit(ctx, sexp_opcode_code(op)); + } + + /* emit optional folding of operator */ + if ((num_args > 2) + && (sexp_opcode_class(op) == OPC_ARITHMETIC + || sexp_opcode_class(op) == OPC_ARITHMETIC_INV)) + for (i=num_args-2; i>0; i--) + emit(ctx, sexp_opcode_code(op)); + + sexp_context_depth(ctx) -= (num_args-1); + sexp_gc_release(ctx, ls, s_ls); +} + +static void generate_general_app (sexp ctx, sexp app) { + sexp_uint_t len = sexp_unbox_integer(sexp_length(ctx, sexp_cdr(app))), + tailp = sexp_context_tailp(ctx); + sexp_gc_var(ctx, ls, s_ls); + sexp_gc_preserve(ctx, ls, s_ls); + + /* push the arguments onto the stack */ + sexp_context_tailp(ctx) = 0; + for (ls=sexp_reverse(ctx, sexp_cdr(app)); sexp_pairp(ls); ls=sexp_cdr(ls)) + generate(ctx, sexp_car(ls)); + + /* push the operator onto the stack */ + generate(ctx, sexp_car(app)); + + /* maybe overwrite the current frame */ + emit(ctx, (tailp ? OP_TAIL_CALL : OP_CALL)); + emit_word(ctx, (sexp_uint_t)sexp_make_integer(len)); + + sexp_context_depth(ctx) -= len; + sexp_gc_release(ctx, ls, s_ls); +} + +static void generate_app (sexp ctx, sexp app) { + if (sexp_opcodep(sexp_car(app))) + generate_opcode_app(ctx, app); + else + generate_general_app(ctx, app); +} + +static void generate_lambda (sexp ctx, sexp lambda) { + sexp ctx2, fv, ls, flags, len, ref, prev_lambda, prev_fv; + sexp_uint_t k; + sexp_gc_var(ctx, tmp, s_tmp); + sexp_gc_var(ctx, bc, s_bc); + sexp_gc_preserve(ctx, tmp, s_tmp); + sexp_gc_preserve(ctx, bc, s_bc); + prev_lambda = sexp_context_lambda(ctx); + prev_fv = sexp_lambdap(prev_lambda) ? sexp_lambda_fv(prev_lambda) : SEXP_NULL; + fv = sexp_lambda_fv(lambda); + ctx2 = sexp_make_context(ctx, sexp_context_stack(ctx), sexp_context_env(ctx)); + sexp_context_lambda(ctx2) = lambda; + /* allocate space for local vars */ + for (ls=sexp_lambda_locals(lambda); sexp_pairp(ls); ls=sexp_cdr(ls)) + emit_push(ctx2, SEXP_VOID); + /* box mutable vars */ + for (ls=sexp_lambda_sv(lambda); sexp_pairp(ls); ls=sexp_cdr(ls)) { + k = sexp_param_index(lambda, sexp_car(ls)); + if (k >= 0) { + emit(ctx2, OP_LOCAL_REF); + emit_word(ctx2, k); + emit_push(ctx2, sexp_car(ls)); + emit(ctx2, OP_CONS); + emit(ctx2, OP_LOCAL_SET); + emit_word(ctx2, k); + emit(ctx2, OP_DROP); + } + } + sexp_context_tailp(ctx2) = 1; + generate(ctx2, sexp_lambda_body(lambda)); + flags = sexp_make_integer((sexp_listp(ctx2, sexp_lambda_params(lambda)) + == SEXP_FALSE) ? 1uL : 0uL); + len = sexp_length(ctx2, sexp_lambda_params(lambda)); + bc = finalize_bytecode(ctx2); + sexp_bytecode_name(bc) = sexp_lambda_name(lambda); + if (sexp_nullp(fv)) { + /* shortcut, no free vars */ + tmp = sexp_make_vector(ctx2, sexp_make_integer(0), SEXP_VOID); + tmp = sexp_make_procedure(ctx2, flags, len, bc, tmp); + sexp_push(ctx, sexp_bytecode_literals(sexp_context_bc(ctx)), tmp); + generate_lit(ctx, tmp); + } else { + /* push the closed vars */ + emit_push(ctx, SEXP_VOID); + emit_push(ctx, sexp_length(ctx, fv)); + emit(ctx, OP_MAKE_VECTOR); + sexp_context_depth(ctx)--; + for (k=0; sexp_pairp(fv); fv=sexp_cdr(fv), k++) { + ref = sexp_car(fv); + generate_non_global_ref(ctx, sexp_ref_name(ref), sexp_ref_cell(ref), + prev_lambda, prev_fv, 0); + emit_push(ctx, sexp_make_integer(k)); + emit(ctx, OP_STACK_REF); + emit_word(ctx, 3); + emit(ctx, OP_VECTOR_SET); + emit(ctx, OP_DROP); + sexp_context_depth(ctx)--; + } + /* push the additional procedure info and make the closure */ + emit_push(ctx, bc); + emit_push(ctx, len); + emit_push(ctx, flags); + emit(ctx, OP_MAKE_PROCEDURE); + } + sexp_gc_release(ctx, tmp, s_tmp); +} + +static void generate (sexp ctx, sexp x) { + if (sexp_pointerp(x)) { + switch (sexp_pointer_tag(x)) { + case SEXP_PAIR: generate_app(ctx, x); break; + case SEXP_LAMBDA: generate_lambda(ctx, x); break; + case SEXP_CND: generate_cnd(ctx, x); break; + case SEXP_REF: generate_ref(ctx, x, 1); break; + case SEXP_SET: generate_set(ctx, x); break; + case SEXP_SEQ: generate_seq(ctx, sexp_seq_ls(x)); break; + case SEXP_LIT: generate_lit(ctx, sexp_lit_value(x)); break; + default: generate_lit(ctx, x); + } + } else { + generate_lit(ctx, x); + } +} + +static sexp insert_free_var (sexp ctx, sexp x, sexp fv) { + sexp name=sexp_ref_name(x), loc=sexp_ref_loc(x), ls; + for (ls=fv; sexp_pairp(ls); ls=sexp_cdr(ls)) + if ((name == sexp_ref_name(sexp_car(ls))) + && (loc == sexp_ref_loc(sexp_car(ls)))) + return fv; + return sexp_cons(ctx, x, fv); +} + +static sexp union_free_vars (sexp ctx, sexp fv1, sexp fv2) { + sexp_gc_var(ctx, res, s_res); + if (sexp_nullp(fv2)) + return fv1; + sexp_gc_preserve(ctx, res, s_res); + for (res=fv2; sexp_pairp(fv1); fv1=sexp_cdr(fv1)) + res = insert_free_var(ctx, sexp_car(fv1), res); + sexp_gc_release(ctx, res, s_res); + return res; +} + +static sexp diff_free_vars (sexp ctx, sexp lambda, sexp fv, sexp params) { + sexp_gc_var(ctx, res, s_res); + sexp_gc_preserve(ctx, res, s_res); + res = SEXP_NULL; + for ( ; sexp_pairp(fv); fv=sexp_cdr(fv)) + if ((sexp_ref_loc(sexp_car(fv)) != lambda) + || (sexp_memq(NULL, sexp_ref_name(sexp_car(fv)), params) + == SEXP_FALSE)) + sexp_push(ctx, res, sexp_car(fv)); + sexp_gc_release(ctx, res, s_res); + return res; +} + +static sexp free_vars (sexp ctx, sexp x, sexp fv) { + sexp_gc_var(ctx, fv1, s_fv1); + sexp_gc_var(ctx, fv2, s_fv2); + sexp_gc_preserve(ctx, fv1, s_fv1); + sexp_gc_preserve(ctx, fv2, s_fv2); + fv1 = fv; + if (sexp_lambdap(x)) { + fv1 = free_vars(ctx, sexp_lambda_body(x), SEXP_NULL); + fv2 = sexp_flatten_dot(ctx, sexp_lambda_params(x)); + fv2 = sexp_append2(ctx, sexp_lambda_locals(x), fv2); + fv2 = diff_free_vars(ctx, x, fv1, fv2); + sexp_lambda_fv(x) = fv2; + fv1 = union_free_vars(ctx, fv2, fv); + } else if (sexp_pairp(x)) { + for ( ; sexp_pairp(x); x=sexp_cdr(x)) + fv1 = free_vars(ctx, sexp_car(x), fv1); + } else if (sexp_cndp(x)) { + fv1 = free_vars(ctx, sexp_cnd_test(x), fv); + fv1 = free_vars(ctx, sexp_cnd_pass(x), fv1); + fv1 = free_vars(ctx, sexp_cnd_fail(x), fv1); + } else if (sexp_seqp(x)) { + for (x=sexp_seq_ls(x); sexp_pairp(x); x=sexp_cdr(x)) + fv1 = free_vars(ctx, sexp_car(x), fv1); + } else if (sexp_setp(x)) { + fv1 = free_vars(ctx, sexp_set_value(x), fv); + fv1 = free_vars(ctx, sexp_set_var(x), fv1); + } else if (sexp_refp(x) && sexp_lambdap(sexp_ref_loc(x))) { + fv1 = insert_free_var(ctx, x, fv); + } else if (sexp_synclop(x)) { + fv1 = free_vars(ctx, sexp_synclo_expr(x), fv); + } + sexp_gc_release(ctx, fv1, s_fv1); + return fv1; +} + +static sexp make_param_list(sexp ctx, sexp_uint_t i) { + sexp_gc_var(ctx, res, s_res); + sexp_gc_preserve(ctx, res, s_res); + res = SEXP_NULL; + for ( ; i>0; i--) + res = sexp_cons(ctx, sexp_make_integer(i), res); + sexp_gc_release(ctx, res, s_res); + return res; +} + +static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i) { + sexp ls, bc, res, env; + sexp_gc_var(ctx, params, s_params); + sexp_gc_var(ctx, ref, s_ref); + sexp_gc_var(ctx, refs, s_refs); + sexp_gc_var(ctx, lambda, s_lambda); + sexp_gc_var(ctx, ctx2, s_ctx2); + if (i == sexp_opcode_num_args(op) && sexp_opcode_proc(op)) + return sexp_opcode_proc(op); /* return before preserving */ + sexp_gc_preserve(ctx, params, s_params); + sexp_gc_preserve(ctx, ref, s_ref); + sexp_gc_preserve(ctx, refs, s_refs); + sexp_gc_preserve(ctx, lambda, s_lambda); + sexp_gc_preserve(ctx, ctx2, s_ctx2); + params = make_param_list(ctx, i); + lambda = sexp_make_lambda(ctx, params); + ctx2 = sexp_make_child_context(ctx, lambda); + env = extend_env(ctx2, sexp_context_env(ctx), params, lambda); + sexp_context_env(ctx2) = env; + for (ls=params, refs=SEXP_NULL; sexp_pairp(ls); ls=sexp_cdr(ls)) { + ref = sexp_make_ref(ctx2, sexp_car(ls), env_cell(env, sexp_car(ls))); + sexp_push(ctx2, refs, ref); + } + refs = sexp_reverse(ctx2, refs); + refs = sexp_cons(ctx2, op, refs); + generate_opcode_app(ctx2, refs); + bc = finalize_bytecode(ctx2); + sexp_bytecode_name(bc) = sexp_c_string(ctx2, sexp_opcode_name(op), -1); + res = sexp_make_procedure(ctx2, sexp_make_integer(0), sexp_make_integer(i), + bc, SEXP_VOID); + if (i == sexp_opcode_num_args(op)) + sexp_opcode_proc(op) = res; + sexp_gc_release(ctx, params, s_params); + return res; +} + +/*********************** the virtual machine **************************/ + +static sexp sexp_save_stack(sexp ctx, sexp *stack, sexp_uint_t to) { + sexp res, *data; + sexp_uint_t i; + res = sexp_make_vector(ctx, sexp_make_integer(to), SEXP_VOID); + data = sexp_vector_data(res); + for (i=0; i= INIT_STACK_SIZE) + errx(70, "out of stack space\n"); +#endif + i = sexp_unbox_integer(_WORD0); + tmp1 = _ARG1; + make_call: + if (sexp_opcodep(tmp1)) { + /* compile non-inlined opcode applications on the fly */ + sexp_context_top(ctx) = top; + tmp1 = make_opcode_procedure(ctx, tmp1, i); + if (sexp_exceptionp(tmp1)) { + _ARG1 = tmp1; + goto call_error_handler; + } + } + if (! sexp_procedurep(tmp1)) + sexp_raise("non procedure application", sexp_list1(ctx, tmp1)); + j = i - sexp_unbox_integer(sexp_procedure_num_args(tmp1)); + if (j < 0) + sexp_raise("not enough args", + sexp_list2(ctx, tmp1, sexp_make_integer(i))); + if (j > 0) { + if (sexp_procedure_variadic_p(tmp1)) { + stack[top-i-1] = sexp_cons(ctx, stack[top-i-1], SEXP_NULL); + for (k=top-i; k=top-i; k--) + stack[k] = stack[k-1]; + stack[top-i-1] = SEXP_NULL; + top++; + i++; + } + _ARG1 = sexp_make_integer(i); + stack[top] = sexp_make_integer(ip+sizeof(sexp)-sexp_bytecode_data(bc)); + stack[top+1] = self; + stack[top+2] = sexp_make_integer(fp); + top += 3; + self = tmp1; + bc = sexp_procedure_code(self); + ip = sexp_bytecode_data(bc); + cp = sexp_procedure_vars(self); + fp = top-4; + break; + case OP_FCALL0: + sexp_context_top(ctx) = top; + _PUSH(((sexp_proc1)_UWORD0)(ctx)); + ip += sizeof(sexp); + sexp_check_exception(); + break; + case OP_FCALL1: + sexp_context_top(ctx) = top; + _ARG1 = ((sexp_proc2)_UWORD0)(ctx, _ARG1); + ip += sizeof(sexp); + sexp_check_exception(); + break; + case OP_FCALL2: + sexp_context_top(ctx) = top; + _ARG2 = ((sexp_proc3)_UWORD0)(ctx, _ARG1, _ARG2); + top--; + ip += sizeof(sexp); + sexp_check_exception(); + break; + case OP_FCALL3: + sexp_context_top(ctx) = top; + _ARG3 =((sexp_proc4)_UWORD0)(ctx, _ARG1, _ARG2, _ARG3); + top -= 2; + ip += sizeof(sexp); + sexp_check_exception(); + break; + case OP_FCALL4: + sexp_context_top(ctx) = top; + _ARG4 =((sexp_proc5)_UWORD0)(ctx, _ARG1, _ARG2, _ARG3, _ARG4); + top -= 3; + ip += sizeof(sexp); + sexp_check_exception(); + break; + case OP_FCALL5: + sexp_context_top(ctx) = top; + _ARG5 =((sexp_proc6)_UWORD0)(ctx, _ARG1, _ARG2, _ARG3, _ARG4, _ARG5); + top -= 4; + ip += sizeof(sexp); + sexp_check_exception(); + break; + case OP_FCALL6: + sexp_context_top(ctx) = top; + _ARG6 =((sexp_proc7)_UWORD0)(ctx, _ARG1, _ARG2, _ARG3, _ARG4, _ARG5, _ARG6); + top -= 5; + ip += sizeof(sexp); + sexp_check_exception(); + break; + case OP_EVAL: + sexp_context_top(ctx) = top; + _ARG1 = sexp_eval(ctx, _ARG1); + sexp_check_exception(); + break; + case OP_JUMP_UNLESS: + if (stack[--top] == SEXP_FALSE) + ip += _SWORD0; + else + ip += sizeof(sexp_sint_t); + break; + case OP_JUMP: + ip += _SWORD0; + break; + case OP_PUSH: + _PUSH(_WORD0); + ip += sizeof(sexp); + break; + case OP_DROP: + top--; + break; + case OP_GLOBAL_REF: + if (sexp_cdr(_WORD0) == SEXP_UNDEF) + sexp_raise("undefined variable", sexp_list1(ctx, sexp_car(_WORD0))); + /* ... FALLTHROUGH ... */ + case OP_GLOBAL_KNOWN_REF: + _PUSH(sexp_cdr(_WORD0)); + ip += sizeof(sexp); + break; + case OP_STACK_REF: /* `pick' in forth */ + stack[top] = stack[top - _SWORD0]; + ip += sizeof(sexp); + top++; + break; + case OP_LOCAL_REF: + stack[top] = stack[fp - 1 - _SWORD0]; + ip += sizeof(sexp); + top++; + break; + case OP_LOCAL_SET: + stack[fp - 1 - _SWORD0] = _ARG1; + _ARG1 = SEXP_VOID; + ip += sizeof(sexp); + break; + case OP_CLOSURE_REF: + _PUSH(sexp_vector_ref(cp, sexp_make_integer(_WORD0))); + ip += sizeof(sexp); + break; + case OP_VECTOR_REF: + if (! sexp_vectorp(_ARG1)) + sexp_raise("vector-ref: not a vector", sexp_list1(ctx, _ARG1)); + _ARG2 = sexp_vector_ref(_ARG1, _ARG2); + top--; + break; + case OP_VECTOR_SET: + if (! sexp_vectorp(_ARG1)) + sexp_raise("vector-set!: not a vector", sexp_list1(ctx, _ARG1)); + else if (sexp_immutablep(_ARG1)) + sexp_raise("vector-set!: immutable vector", sexp_list1(ctx, _ARG1)); + sexp_vector_set(_ARG1, _ARG2, _ARG3); + _ARG3 = SEXP_VOID; + top-=2; + break; + case OP_VECTOR_LENGTH: + _ARG1 = sexp_make_integer(sexp_vector_length(_ARG1)); + break; + case OP_STRING_REF: + _ARG2 = sexp_string_ref(_ARG1, _ARG2); + top--; + break; + case OP_STRING_SET: + if (! sexp_stringp(_ARG1)) + sexp_raise("string-set!: not a string", sexp_list1(ctx, _ARG1)); + else if (sexp_immutablep(_ARG1)) + sexp_raise("string-set!: immutable string", sexp_list1(ctx, _ARG1)); + fprintf(stderr, "string-set! %p (immutable: %d)\n", _ARG1, sexp_immutablep(_ARG1)); + sexp_string_set(_ARG1, _ARG2, _ARG3); + _ARG3 = SEXP_VOID; + top-=2; + break; + case OP_STRING_LENGTH: + _ARG1 = sexp_make_integer(sexp_string_length(_ARG1)); + break; + case OP_MAKE_PROCEDURE: + sexp_context_top(ctx) = top; + _ARG4 = sexp_make_procedure(ctx, _ARG1, _ARG2, _ARG3, _ARG4); + top-=3; + break; + case OP_MAKE_VECTOR: + sexp_context_top(ctx) = top; + _ARG2 = sexp_make_vector(ctx, _ARG1, _ARG2); + top--; + break; + case OP_AND: + _ARG2 = sexp_make_boolean((_ARG1 != SEXP_FALSE) && (_ARG2 != SEXP_FALSE)); + top--; + break; + case OP_EOFP: + _ARG1 = sexp_make_boolean(_ARG1 == SEXP_EOF); break; + case OP_NULLP: + _ARG1 = sexp_make_boolean(sexp_nullp(_ARG1)); break; + case OP_INTEGERP: + _ARG1 = sexp_make_boolean(sexp_integerp(_ARG1)); break; + case OP_SYMBOLP: + _ARG1 = sexp_make_boolean(sexp_symbolp(_ARG1)); break; + case OP_CHARP: + _ARG1 = sexp_make_boolean(sexp_charp(_ARG1)); break; + case OP_TYPEP: + _ARG1 = sexp_make_boolean(sexp_pointerp(_ARG1) + && (sexp_pointer_tag(_ARG1) + == _UWORD0)); + ip += sizeof(sexp); + break; + case OP_CAR: + if (! sexp_pairp(_ARG1)) + sexp_raise("car: not a pair", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_car(_ARG1); break; + case OP_CDR: + if (! sexp_pairp(_ARG1)) + sexp_raise("cdr: not a pair", sexp_list1(ctx, _ARG1)); + _ARG1 = sexp_cdr(_ARG1); break; + case OP_SET_CAR: + if (! sexp_pairp(_ARG1)) + sexp_raise("set-car!: not a pair", sexp_list1(ctx, _ARG1)); + else if (sexp_immutablep(_ARG1)) + sexp_raise("set-car!: immutable pair", sexp_list1(ctx, _ARG1)); + sexp_car(_ARG1) = _ARG2; + _ARG2 = SEXP_VOID; + top--; + break; + case OP_SET_CDR: + if (! sexp_pairp(_ARG1)) + sexp_raise("set-cdr!: not a pair", sexp_list1(ctx, _ARG1)); + else if (sexp_immutablep(_ARG1)) + sexp_raise("set-cdr!: immutable pair", sexp_list1(ctx, _ARG1)); + sexp_cdr(_ARG1) = _ARG2; + _ARG2 = SEXP_VOID; + top--; + break; + case OP_CONS: + sexp_context_top(ctx) = top; + _ARG2 = sexp_cons(ctx, _ARG1, _ARG2); + top--; + break; + case OP_ADD: + if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) + _ARG2 = sexp_fx_add(_ARG1, _ARG2); +#if USE_FLONUMS + else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_fp_add(ctx, _ARG1, _ARG2); + else if (sexp_flonump(_ARG1) && sexp_integerp(_ARG2)) + _ARG2 = sexp_make_flonum(ctx, sexp_flonum_value(_ARG1) + (double)sexp_unbox_integer(_ARG2)); + else if (sexp_integerp(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_make_flonum(ctx, (double)sexp_unbox_integer(_ARG1) + sexp_flonum_value(_ARG2)); +#endif + else sexp_raise("+: not a number", sexp_list2(ctx, _ARG1, _ARG2)); + top--; + break; + case OP_SUB: + if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) + _ARG2 = sexp_fx_sub(_ARG1, _ARG2); +#if USE_FLONUMS + else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_fp_sub(ctx, _ARG1, _ARG2); + else if (sexp_flonump(_ARG1) && sexp_integerp(_ARG2)) + _ARG2 = sexp_make_flonum(ctx, sexp_flonum_value(_ARG1) - (double)sexp_unbox_integer(_ARG2)); + else if (sexp_integerp(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_make_flonum(ctx, (double)sexp_unbox_integer(_ARG1) - sexp_flonum_value(_ARG2)); +#endif + else sexp_raise("-: not a number", sexp_list2(ctx, _ARG1, _ARG2)); + top--; + break; + case OP_MUL: + if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) + _ARG2 = sexp_fx_mul(_ARG1, _ARG2); +#if USE_FLONUMS + else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_fp_mul(ctx, _ARG1, _ARG2); + else if (sexp_flonump(_ARG1) && sexp_integerp(_ARG2)) + _ARG2 = sexp_make_flonum(ctx, sexp_flonum_value(_ARG1) * (double)sexp_unbox_integer(_ARG2)); + else if (sexp_integerp(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_make_flonum(ctx, (double)sexp_unbox_integer(_ARG1) * sexp_flonum_value(_ARG2)); +#endif + else sexp_raise("*: not a number", sexp_list2(ctx, _ARG1, _ARG2)); + top--; + break; + case OP_DIV: + if (_ARG2 == sexp_make_integer(0)) + sexp_raise("divide by zero", SEXP_NULL); + if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) { +#if USE_FLONUMS + _ARG1 = sexp_integer_to_flonum(ctx, _ARG1); + _ARG2 = sexp_integer_to_flonum(ctx, _ARG2); + _ARG2 = sexp_fp_div(ctx, _ARG1, _ARG2); +#else + _ARG2 = sexp_fx_div(_ARG1, _ARG2); +#endif + } +#if USE_FLONUMS + else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_fp_div(ctx, _ARG1, _ARG2); + else if (sexp_flonump(_ARG1) && sexp_integerp(_ARG2)) + _ARG2 = sexp_make_flonum(ctx, sexp_flonum_value(_ARG1) / (double)sexp_unbox_integer(_ARG2)); + else if (sexp_integerp(_ARG1) && sexp_flonump(_ARG2)) + _ARG2 = sexp_make_flonum(ctx, (double)sexp_unbox_integer(_ARG1) / sexp_flonum_value(_ARG2)); +#endif + else sexp_raise("/: not a number", sexp_list2(ctx, _ARG1, _ARG2)); + top--; + break; + case OP_QUOTIENT: + if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) { + if (_ARG2 == sexp_make_integer(0)) + sexp_raise("divide by zero", SEXP_NULL); + _ARG2 = sexp_fx_div(_ARG1, _ARG2); + top--; + } + else sexp_raise("quotient: not an integer", sexp_list2(ctx, _ARG1, _ARG2)); + break; + case OP_REMAINDER: + if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) { + if (_ARG2 == sexp_make_integer(0)) + sexp_raise("divide by zero", SEXP_NULL); + tmp1 = sexp_fx_rem(_ARG1, _ARG2); + top--; + _ARG1 = tmp1; + } + else sexp_raise("remainder: not an integer", sexp_list2(ctx, _ARG1, _ARG2)); + break; + case OP_NEGATIVE: + if (sexp_integerp(_ARG1)) + _ARG1 = sexp_make_integer(-sexp_unbox_integer(_ARG1)); +#if USE_FLONUMS + else if (sexp_flonump(_ARG1)) + _ARG1 = sexp_make_flonum(ctx, -sexp_flonum_value(_ARG1)); +#endif + else sexp_raise("-: not a number", sexp_list1(ctx, _ARG1)); + break; + case OP_INVERSE: + if (sexp_integerp(_ARG1)) + _ARG1 = sexp_make_flonum(ctx, 1/(double)sexp_unbox_integer(_ARG1)); +#if USE_FLONUMS + else if (sexp_flonump(_ARG1)) + _ARG1 = sexp_make_flonum(ctx, 1/sexp_flonum_value(_ARG1)); +#endif + else sexp_raise("/: not a number", sexp_list1(ctx, _ARG1)); + break; + case OP_LT: + if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) + i = (sexp_sint_t)_ARG1 < (sexp_sint_t)_ARG2; +#if USE_FLONUMS + else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) + i = sexp_flonum_value(_ARG1) < sexp_flonum_value(_ARG2); + else if (sexp_flonump(_ARG1) && sexp_integerp(_ARG2)) + i = sexp_flonum_value(_ARG1) < (double)sexp_unbox_integer(_ARG2); + else if (sexp_integerp(_ARG1) && sexp_flonump(_ARG2)) + i = (double)sexp_unbox_integer(_ARG1) < sexp_flonum_value(_ARG2); +#endif + else sexp_raise("<: not a number", sexp_list2(ctx, _ARG1, _ARG2)); + _ARG2 = sexp_make_boolean(i); + top--; + break; + case OP_LE: + if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) + i = (sexp_sint_t)_ARG1 <= (sexp_sint_t)_ARG2; +#if USE_FLONUMS + else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) + i = sexp_flonum_value(_ARG1) <= sexp_flonum_value(_ARG2); + else if (sexp_flonump(_ARG1) && sexp_integerp(_ARG2)) + i = sexp_flonum_value(_ARG1) <= (double)sexp_unbox_integer(_ARG2); + else if (sexp_integerp(_ARG1) && sexp_flonump(_ARG2)) + i = (double)sexp_unbox_integer(_ARG1) <= sexp_flonum_value(_ARG2); +#endif + else sexp_raise("<=: not a number", sexp_list2(ctx, _ARG1, _ARG2)); + _ARG2 = sexp_make_boolean(i); + top--; + break; + case OP_EQN: + if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) + i = _ARG1 == _ARG2; +#if USE_FLONUMS + else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2)) + i = sexp_flonum_value(_ARG1) == sexp_flonum_value(_ARG2); + else if (sexp_flonump(_ARG1) && sexp_integerp(_ARG2)) + i = sexp_flonum_value(_ARG1) == (double)sexp_unbox_integer(_ARG2); + else if (sexp_integerp(_ARG1) && sexp_flonump(_ARG2)) + i = (double)sexp_unbox_integer(_ARG1) == sexp_flonum_value(_ARG2); +#endif + else sexp_raise("=: not a number", sexp_list2(ctx, _ARG1, _ARG2)); + _ARG2 = sexp_make_boolean(i); + top--; + break; + case OP_EQ: + _ARG2 = sexp_make_boolean(_ARG1 == _ARG2); + top--; + break; + case OP_FIX2FLO: + if (sexp_integerp(_ARG1)) + _ARG1 = sexp_integer_to_flonum(ctx, _ARG1); + else +#if USE_FLONUMS + if (! sexp_flonump(_ARG1)) +#endif + sexp_raise("exact->inexact: not a number", sexp_list1(ctx, _ARG1)); + break; + case OP_FLO2FIX: +#if USE_FLONUMS + if (sexp_flonump(_ARG1)) + _ARG1 = sexp_make_integer((sexp_sint_t)sexp_flonum_value(_ARG1)); + else +#endif + if (! sexp_integerp(_ARG1)) + sexp_raise("inexact->exact: not a number", sexp_list1(ctx, _ARG1)); + break; + case OP_CHAR2INT: + _ARG1 = sexp_make_integer(sexp_unbox_character(_ARG1)); + break; + case OP_INT2CHAR: + _ARG1 = sexp_make_character(sexp_unbox_integer(_ARG1)); + break; + case OP_CHAR_UPCASE: + _ARG1 = sexp_make_character(toupper(sexp_unbox_character(_ARG1))); + break; + case OP_CHAR_DOWNCASE: + _ARG1 = sexp_make_character(tolower(sexp_unbox_character(_ARG1))); + break; + case OP_DISPLAY: + if (sexp_stringp(_ARG1)) { + sexp_write_string(ctx, sexp_string_data(_ARG1), _ARG2); + _ARG2 = SEXP_VOID; + top--; + break; + } else if (sexp_charp(_ARG1)) { + sexp_write_char(ctx, sexp_unbox_character(_ARG1), _ARG2); + _ARG2 = SEXP_VOID; + top--; + break; + } + /* ... FALLTHROUGH ... */ + case OP_WRITE: + sexp_write(ctx, _ARG1, _ARG2); + _ARG2 = SEXP_VOID; + top--; + break; + case OP_WRITE_CHAR: + sexp_write_char(ctx, sexp_unbox_character(_ARG1), _ARG2); + _ARG2 = SEXP_VOID; + top--; + break; + case OP_NEWLINE: + sexp_newline(ctx, _ARG1); + _ARG1 = SEXP_VOID; + break; + case OP_FLUSH_OUTPUT: + sexp_flush(ctx, _ARG1); + _ARG1 = SEXP_VOID; + break; + case OP_READ: + sexp_context_top(ctx) = top; + _ARG1 = sexp_read(ctx, _ARG1); + sexp_check_exception(); + break; + case OP_READ_CHAR: + i = sexp_read_char(ctx, _ARG1); + _ARG1 = (i == EOF) ? SEXP_EOF : sexp_make_character(i); + break; + case OP_PEEK_CHAR: + i = sexp_read_char(ctx, _ARG1); + sexp_push_char(ctx, i, _ARG1); + _ARG1 = (i == EOF) ? SEXP_EOF : sexp_make_character(i); + break; + case OP_RET: + i = sexp_unbox_integer(stack[fp]); + stack[fp-i] = _ARG1; + top = fp-i+1; + self = stack[fp+2]; + bc = sexp_procedure_code(self); + ip = sexp_bytecode_data(bc) + sexp_unbox_integer(stack[fp+1]); + cp = sexp_procedure_vars(self); + fp = sexp_unbox_integer(stack[fp+3]); + break; + case OP_DONE: + goto end_loop; + default: + sexp_raise("unknown opcode", sexp_list1(ctx, sexp_make_integer(*(ip-1)))); + } + goto loop; + + end_loop: + sexp_gc_release(ctx, self, s_self); + sexp_context_top(ctx) = top; + return _ARG1; +} + +/************************ library procedures **************************/ + +static sexp sexp_exception_type_func (sexp ctx, sexp exn) { + if (sexp_exceptionp(exn)) + return sexp_exception_kind(exn); + else + return sexp_type_exception(ctx, "not an exception", exn); +} + +static sexp sexp_open_input_file (sexp ctx, sexp path) { + FILE *in; + if (! sexp_stringp(path)) + return sexp_type_exception(ctx, "not a string", path); + in = fopen(sexp_string_data(path), "r"); + if (! in) + return + sexp_user_exception(ctx, SEXP_FALSE, "couldn't open input file", path); + return sexp_make_input_port(ctx, in, path); +} + +static sexp sexp_open_output_file (sexp ctx, sexp path) { + FILE *out; + if (! sexp_stringp(path)) + return sexp_type_exception(ctx, "not a string", path); + out = fopen(sexp_string_data(path), "w"); + if (! out) + return + sexp_user_exception(ctx, SEXP_FALSE, "couldn't open output file", path); + return sexp_make_input_port(ctx, out, path); +} + +static sexp sexp_close_port (sexp ctx, sexp port) { + if (! sexp_portp(port)) + return sexp_type_exception(ctx, "not a port", port); + if (! sexp_port_openp(port)) + return sexp_user_exception(ctx, SEXP_FALSE, "port already closed", port); + if (sexp_port_buf(port)) + free(sexp_port_buf(port)); + if (sexp_port_stream(port)) + fclose(sexp_port_stream(port)); + sexp_port_openp(port) = 0; + return SEXP_VOID; +} + +void sexp_warn_undefs (sexp ctx, sexp from, sexp to, sexp out) { + sexp x; + for (x=from; sexp_pairp(x) && x!=to; x=sexp_cdr(x)) + if (sexp_cdar(x) == SEXP_UNDEF) { + sexp_write_string(ctx, "WARNING: reference to undefined variable: ", out); + sexp_write(ctx, sexp_caar(x), out); + sexp_write_char(ctx, '\n', out); + } +} + +sexp sexp_load (sexp ctx, sexp source, sexp env) { + sexp tmp, out; + sexp_gc_var(ctx, ctx2, s_ctx2); + sexp_gc_var(ctx, x, s_x); + sexp_gc_var(ctx, in, s_in); + sexp_gc_var(ctx, res, s_res); + sexp_gc_preserve(ctx, ctx2, s_ctx2); + sexp_gc_preserve(ctx, x, s_x); + sexp_gc_preserve(ctx, in, s_in); + sexp_gc_preserve(ctx, res, s_res); + res = SEXP_VOID; + in = sexp_open_input_file(ctx, source); + out = env_global_ref(env, the_cur_err_symbol, SEXP_FALSE); + ctx2 = sexp_make_context(ctx, NULL, env); + sexp_context_parent(ctx2) = ctx; + tmp = sexp_env_bindings(env); + sexp_context_tailp(ctx2) = 0; + if (sexp_exceptionp(in)) { + sexp_print_exception(ctx, in, out); + res = in; + } else { + sexp_port_sourcep(in) = 1; + while ((x=sexp_read(ctx, in)) != (sexp) SEXP_EOF) { + res = sexp_eval(ctx2, x); + if (sexp_exceptionp(res)) + break; + } + if (x == SEXP_EOF) + res = SEXP_VOID; + sexp_close_port(ctx, in); +#if USE_WARN_UNDEFS + if (sexp_oportp(out)) + sexp_warn_undefs(ctx, sexp_env_bindings(env), tmp, out); +#endif + } + sexp_gc_release(ctx, ctx2, s_ctx2); + return res; +} + +#if USE_MATH + +#define define_math_op(name, cname) \ + static sexp name (sexp ctx, sexp z) { \ + double d; \ + if (sexp_flonump(z)) \ + d = sexp_flonum_value(z); \ + else if (sexp_integerp(z)) \ + d = (double)sexp_unbox_integer(z); \ + else \ + return sexp_type_exception(ctx, "not a number", z); \ + return sexp_make_flonum(ctx, cname(d)); \ + } + +define_math_op(sexp_exp, exp) +define_math_op(sexp_log, log) +define_math_op(sexp_sin, sin) +define_math_op(sexp_cos, cos) +define_math_op(sexp_tan, tan) +define_math_op(sexp_asin, asin) +define_math_op(sexp_acos, acos) +define_math_op(sexp_atan, atan) +define_math_op(sexp_sqrt, sqrt) +define_math_op(sexp_round, round) +define_math_op(sexp_trunc, trunc) +define_math_op(sexp_floor, floor) +define_math_op(sexp_ceiling, ceil) + +#endif + +static sexp sexp_expt (sexp ctx, sexp x, sexp e) { + double res, x1, e1; + if (sexp_integerp(x)) + x1 = (double)sexp_unbox_integer(x); +#if USE_FLONUMS + else if (sexp_flonump(x)) + x1 = sexp_flonum_value(x); +#endif + else + return sexp_type_exception(ctx, "not a number", x); + if (sexp_integerp(e)) + e1 = (double)sexp_unbox_integer(e); +#if USE_FLONUMS + else if (sexp_flonump(e)) + e1 = sexp_flonum_value(e); +#endif + else + return sexp_type_exception(ctx, "not a number", e); + res = pow(x1, e1); +#if USE_FLONUMS + if ((res > SEXP_MAX_INT) || sexp_flonump(x) || sexp_flonump(e)) + return sexp_make_flonum(ctx, res); +#endif + return sexp_make_integer((sexp_sint_t)round(res)); +} + +static sexp sexp_string_cmp (sexp ctx, sexp str1, sexp str2, sexp ci) { + sexp_sint_t len1, len2, len, diff; + if (! sexp_stringp(str1)) + return sexp_type_exception(ctx, "not a string", str1); + if (! sexp_stringp(str2)) + return sexp_type_exception(ctx, "not a string", str2); + len1 = sexp_string_length(str1); + len2 = sexp_string_length(str2); + len = ((len1next) h = h->next; + return h; +} + +sexp_uint_t sexp_allocated_bytes (sexp x) { + sexp_uint_t res, *len_ptr; + sexp t; + if ((! sexp_pointerp(x)) || (sexp_pointer_tag(x) > SEXP_CONTEXT)) + return sexp_heap_align(1); + t = &(sexp_type_specs[sexp_pointer_tag(x)]); + len_ptr = (sexp_uint_t*) (((char*)x) + sexp_type_size_off(t)); + res = sexp_type_size_base(t) + len_ptr[0] * sexp_type_size_scale(t); + return res; +} + +void sexp_mark (sexp x) { + sexp_uint_t *len_ptr; + sexp_sint_t i, len; + sexp t, *p; + struct sexp_gc_var_t *saves; + loop: + if ((! x) || (! sexp_pointerp(x)) || sexp_gc_mark(x)) + return; + sexp_gc_mark(x) = 1; + if (sexp_contextp(x)) + for (saves=sexp_context_saves(x); saves; saves=saves->next) + if (saves->var) sexp_mark(*(saves->var)); + t = &(sexp_type_specs[sexp_pointer_tag(x)]); + p = (sexp*) (((char*)x) + sexp_type_field_base(t)); + len_ptr = (sexp_uint_t*) (((char*)x) + sexp_type_field_len_off(t)); + len = sexp_type_field_len_base(t) + + len_ptr[0]*sexp_type_field_len_scale(t) - 1; + if (len >= 0) { + for (i=0; inext) { + p = (sexp) (h->data + sexp_heap_align(sexp_sizeof(pair))); + q = h->free_list; + end = (char*)h->data + h->size; + while (((char*)p) < end) { + /* find the preceding and succeeding free list pointers */ + for (r=q->next; r && ((char*)r<(char*)p); q=r, r=r->next) + ; + if ((char*)r == (char*)p) { + p = (sexp) (((char*)p) + r->size); + continue; + } + size = sexp_heap_align(sexp_allocated_bytes(p)); + if ((! sexp_gc_mark(p)) && (! stack_references_pointer_p(ctx, p))) { + sum_freed += size; + if (((((char*)q) + q->size) == (char*)p) && (q != h->free_list)) { + /* merge q with p */ + if (r && ((((char*)p)+size) == (char*)r)) { + /* ... and with r */ + q->next = r->next; + freed = q->size + size + r->size; + p = (sexp) (((char*)p) + size + r->size); + } else { + freed = q->size + size; + p = (sexp) (((char*)p)+size); + } + q->size = freed; + } else { + s = (sexp_free_list)p; + if (r && ((((char*)p)+size) == (char*)r)) { + /* merge p with r */ + s->size = size + r->size; + s->next = r->next; + q->next = s; + freed = size + r->size; + } else { + s->size = size; + s->next = r; + q->next = s; + freed = size; + } + p = (sexp) (((char*)p)+freed); + } + if (freed > max_freed) + max_freed = freed; + } else { + sexp_gc_mark(p) = 0; + p = (sexp) (((char*)p)+size); + } + } + } + sum_freed_ptr[0] = sum_freed; + return sexp_make_integer(max_freed); +} + +sexp sexp_gc (sexp ctx, size_t *sum_freed) { + sexp res; + int i; + sexp_mark(continuation_resumer); + sexp_mark(final_resumer); + for (i=0; isize = size; + h->data = (char*) sexp_heap_align((sexp_uint_t)&(h->data)); + free = h->free_list = (sexp_free_list) h->data; + h->next = NULL; + next = (sexp_free_list) ((char*)free + sexp_heap_align(sexp_sizeof(pair))); + free->size = 0; /* actually sexp_sizeof(pair) */ + free->next = next; + next->size = size - sexp_heap_align(sexp_sizeof(pair)); + next->next = NULL; + return h; +} + +int sexp_grow_heap (sexp ctx, size_t size) { + size_t cur_size, new_size; + sexp_heap h = sexp_heap_last(heap); + cur_size = h->size; + new_size = sexp_heap_align(((cur_size > size) ? cur_size : size) * 2); + h->next = sexp_make_heap(new_size); + return (h->next != NULL); +} + +void* sexp_try_alloc (sexp ctx, size_t size) { + sexp_free_list ls1, ls2, ls3; + sexp_heap h; + for (h=heap; h; h=h->next) + for (ls1=h->free_list, ls2=ls1->next; ls2; ls1=ls2, ls2=ls2->next) + if (ls2->size >= size) { + if (ls2->size >= (size + SEXP_MINIMUM_OBJECT_SIZE)) { + ls3 = (sexp_free_list) (((char*)ls2)+size); /* the tail after ls2 */ + ls3->size = ls2->size - size; + ls3->next = ls2->next; + ls1->next = ls3; + } else { /* take the whole chunk */ + ls1->next = ls2->next; + } + memset((void*)ls2, 0, size); + return ls2; + } + return NULL; +} + +void* sexp_alloc (sexp ctx, size_t size) { + void *res; + size_t max_freed, sum_freed; + sexp_heap h; + size = sexp_heap_align(size); + res = sexp_try_alloc(ctx, size); + if (! res) { + max_freed = sexp_unbox_integer(sexp_gc(ctx, &sum_freed)); + h = sexp_heap_last(heap); + if (((max_freed < size) + || ((h->size - sum_freed) < (h->size*(1 - SEXP_GROW_HEAP_RATIO)))) + && ((! SEXP_MAXIMUM_HEAP_SIZE) || (size < SEXP_MAXIMUM_HEAP_SIZE))) + sexp_grow_heap(ctx, size); + res = sexp_try_alloc(ctx, size); + if (! res) + errx(80, "out of memory allocating %zu bytes, aborting\n", size); + } + return res; +} + +void sexp_gc_init () { + sexp_uint_t size = sexp_heap_align(SEXP_INITIAL_HEAP_SIZE); + heap = sexp_make_heap(size); +#if USE_DEBUG_GC + /* the +32 is a hack, but this is just for debugging anyway */ + stack_base = ((sexp*)&size) + 32; +#endif +} + diff --git a/include/chibi/config.h b/include/chibi/config.h new file mode 100644 index 00000000..e3fdf9b6 --- /dev/null +++ b/include/chibi/config.h @@ -0,0 +1,120 @@ +/* config.h -- general configuration */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +/* uncomment this to use the Boehm conservative GC */ +/* #define USE_BOEHM 1 */ + +/* uncomment this to just malloc manually instead of any GC */ +/* #define USE_MALLOC 1 */ + +/* uncomment this to add conservative checks to the native GC */ +/* #define USE_DEBUG_GC 1 */ + +/* uncomment this if you only want fixnum support */ +/* #define USE_FLONUMS 0 */ + +/* uncomment this if you want immediate flonums */ +/* #define USE_IMMEDIATE_FLONUMS 1 */ + +/* uncomment this if you don't need extended math operations */ +/* #define USE_MATH 0 */ + +/* uncomment this to disable warning about references to undefined variables */ +/* #define USE_WARN_UNDEFS 0 */ + +/* uncomment this to disable huffman-coded immediate symbols */ +/* #define USE_HUFF_SYMS 0 */ + +/* uncomment this to just use a single list for hash tables */ +/* #define USE_HASH_SYMS 0 */ + +/* uncomment this to disable string ports */ +/* #define USE_STRING_STREAMS 0 */ + +/* uncomment this to enable stack overflow checks */ +/* #define USE_CHECK_STACK 1 */ + +/* uncomment this to disable debugging utilities */ +/* #define USE_DEBUG 0 */ + +/************************************************************************/ +/* DEFAULTS - DO NOT MODIFY ANYTHING BELOW THIS LINE */ +/************************************************************************/ + +#if defined(__APPLE__) || defined(__FreeBSD__) || defined(__NetBSD__) || defined(__DragonFly__) || defined(__OpenBSD__) +#define SEXP_BSD 1 +#else +#define SEXP_BSD 0 +#define _GNU_SOURCE +#endif + +#ifndef USE_BOEHM +#define USE_BOEHM 0 +#endif + +#ifndef USE_MALLOC +#define USE_MALLOC 0 +#endif + +#ifndef USE_DEBUG_GC +#define USE_DEBUG_GC 0 +#endif + +#ifndef USE_FLONUMS +#define USE_FLONUMS 1 +#endif + +#ifndef USE_IMMEDIATE_FLONUMS +#define USE_IMMEDIATE_FLONUMS 0 +#endif + +#ifndef USE_MATH +#define USE_MATH 1 +#endif + +#ifndef USE_WARN_UNDEFS +#define USE_WARN_UNDEFS 1 +#endif + +#ifndef USE_HUFF_SYMS +#define USE_HUFF_SYMS 1 +#endif + +#ifndef USE_HASH_SYMS +#define USE_HASH_SYMS 1 +#endif + +#ifndef USE_DEBUG +#define USE_DEBUG 1 +#endif + +#ifndef USE_STRING_STREAMS +#define USE_STRING_STREAMS 1 +#endif + +#ifndef USE_CHECK_STACK +#define USE_CHECK_STACK 0 +#endif + +#ifdef PLAN9 + +#define errx(code, msg, ...) exits(msg) +#define exit_normally() exits(NULL) +#define strcasecmp cistrcmp +#define strncasecmp cistrncmp +/* XXXX these are wrong */ +#define trunc floor +#define round(x) floor(x+0.5) + +#else + +#define exit_normally() exit(0) +#if HAVE_ERR_H +#include +#else +/* requires msg be a string literal, and at least one argument */ +#define errx(code, msg, ...) (fprintf(stderr,msg"\n",__VA_ARGS__), exit(code)) +#endif + +#endif diff --git a/include/chibi/eval.h b/include/chibi/eval.h new file mode 100644 index 00000000..1b51c8f5 --- /dev/null +++ b/include/chibi/eval.h @@ -0,0 +1,140 @@ +/* eval.h -- headers for eval library */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#ifndef SEXP_EVAL_H +#define SEXP_EVAL_H + +#include "chibi/sexp.h" + +/************************* additional types ***************************/ + +#define INIT_BCODE_SIZE 128 +#define INIT_STACK_SIZE 1024 + +#define sexp_init_file "init.scm" + +/* procedure types */ +typedef sexp (*sexp_proc0) (); +typedef sexp (*sexp_proc1) (sexp); +typedef sexp (*sexp_proc2) (sexp, sexp); +typedef sexp (*sexp_proc3) (sexp, sexp, sexp); +typedef sexp (*sexp_proc4) (sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc5) (sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc6) (sexp, sexp, sexp, sexp, sexp, sexp); +typedef sexp (*sexp_proc7) (sexp, sexp, sexp, sexp, sexp, sexp, sexp); + +enum core_form_names { + CORE_DEFINE = 1, + CORE_SET, + CORE_LAMBDA, + CORE_IF, + CORE_BEGIN, + CORE_QUOTE, + CORE_DEFINE_SYNTAX, + CORE_LET_SYNTAX, + CORE_LETREC_SYNTAX, +}; + +enum opcode_classes { + OPC_GENERIC = 1, + OPC_TYPE_PREDICATE, + OPC_PREDICATE, + OPC_ARITHMETIC, + OPC_ARITHMETIC_INV, + OPC_ARITHMETIC_CMP, + OPC_IO, + OPC_CONSTRUCTOR, + OPC_ACCESSOR, + OPC_PARAMETER, + OPC_FOREIGN, +}; + +enum opcode_names { + OP_NOOP, + OP_RAISE, + OP_RESUMECC, + OP_CALLCC, + OP_APPLY1, + OP_TAIL_CALL, + OP_CALL, + OP_FCALL0, + OP_FCALL1, + OP_FCALL2, + OP_FCALL3, + OP_FCALL4, + OP_FCALL5, + OP_FCALL6, + OP_EVAL, + OP_JUMP_UNLESS, + OP_JUMP, + OP_PUSH, + OP_DROP, + OP_GLOBAL_REF, + OP_GLOBAL_KNOWN_REF, + OP_STACK_REF, + OP_LOCAL_REF, + OP_LOCAL_SET, + OP_CLOSURE_REF, + OP_VECTOR_REF, + OP_VECTOR_SET, + OP_VECTOR_LENGTH, + OP_STRING_REF, + OP_STRING_SET, + OP_STRING_LENGTH, + OP_MAKE_PROCEDURE, + OP_MAKE_VECTOR, + OP_AND, + OP_NULLP, + OP_INTEGERP, + OP_SYMBOLP, + OP_CHARP, + OP_EOFP, + OP_TYPEP, + OP_CAR, + OP_CDR, + OP_SET_CAR, + OP_SET_CDR, + OP_CONS, + OP_ADD, + OP_SUB, + OP_MUL, + OP_DIV, + OP_QUOTIENT, + OP_REMAINDER, + OP_NEGATIVE, + OP_INVERSE, + OP_LT, + OP_LE, + OP_EQN, + OP_EQ, + OP_FIX2FLO, + OP_FLO2FIX, + OP_CHAR2INT, + OP_INT2CHAR, + OP_CHAR_UPCASE, + OP_CHAR_DOWNCASE, + OP_DISPLAY, + OP_WRITE, + OP_WRITE_CHAR, + OP_NEWLINE, + OP_FLUSH_OUTPUT, + OP_READ, + OP_READ_CHAR, + OP_PEEK_CHAR, + OP_RET, + OP_DONE, +}; + +/**************************** prototypes ******************************/ + +void sexp_scheme_init(); +sexp sexp_apply(sexp context, sexp proc, sexp args); +sexp sexp_eval(sexp context, sexp obj); +sexp sexp_eval_string(sexp context, char *str); +sexp sexp_load(sexp context, sexp expr, sexp env); +sexp sexp_make_context(sexp context, sexp stack, sexp env); +void sexp_warn_undefs(sexp ctx, sexp from, sexp to, sexp out); + +#endif /* ! SEXP_EVAL_H */ + diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h new file mode 100644 index 00000000..04f9625c --- /dev/null +++ b/include/chibi/sexp.h @@ -0,0 +1,595 @@ +/* sexp.h -- header for sexp library */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#ifndef SEXP_H +#define SEXP_H + +#include "chibi/config.h" +#include "chibi/install.h" + +#include +#include +#ifdef PLAN9 +typedef unsigned long size_t; +#define offsetof(st, m) ((size_t) ((char*)&((st*)(0))->m - (char*)0)) +#else +#include +#include +#include +#include +#include +#include +#endif + +/* tagging system + * bits end in 00: pointer + * 01: fixnum + * 011: immediate flonum (optional) + * 111: immediate symbol (optional) + * 0110: char + * 1110: other immediate object (NULL, TRUE, FALSE) + */ + +#define SEXP_FIXNUM_BITS 2 +#define SEXP_IMMEDIATE_BITS 3 +#define SEXP_EXTENDED_BITS 4 + +#define SEXP_FIXNUM_MASK 3 +#define SEXP_IMMEDIATE_MASK 7 +#define SEXP_EXTENDED_MASK 15 + +#define SEXP_POINTER_TAG 0 +#define SEXP_FIXNUM_TAG 1 +#define SEXP_ISYMBOL_TAG 7 +#define SEXP_IFLONUM_TAG 3 +#define SEXP_CHAR_TAG 6 +#define SEXP_EXTENDED_TAG 14 + +#define SEXP_MAX_INT ((1<<29)-1) +#define SEXP_MIN_INT (-(1<<29)) + +#if USE_HASH_SYMS +#define SEXP_SYMBOL_TABLE_SIZE 389 +#else +#define SEXP_SYMBOL_TABLE_SIZE 1 +#endif + +enum sexp_types { + SEXP_OBJECT, + SEXP_TYPE, + SEXP_FIXNUM, + SEXP_CHAR, + SEXP_BOOLEAN, + SEXP_PAIR, + SEXP_SYMBOL, + SEXP_STRING, + SEXP_VECTOR, + SEXP_FLONUM, + SEXP_BIGNUM, + SEXP_IPORT, + SEXP_OPORT, + SEXP_EXCEPTION, + SEXP_PROCEDURE, + SEXP_MACRO, + SEXP_SYNCLO, + SEXP_ENV, + SEXP_BYTECODE, + SEXP_CORE, + SEXP_OPCODE, + SEXP_LAMBDA, + SEXP_CND, + SEXP_REF, + SEXP_SET, + SEXP_SEQ, + SEXP_LIT, + SEXP_STACK, + SEXP_CONTEXT, + SEXP_NUM_TYPES, +}; + +typedef unsigned long sexp_uint_t; +typedef long sexp_sint_t; +typedef unsigned char sexp_tag_t; +typedef struct sexp_struct *sexp; + +struct sexp_gc_var_t { + sexp *var; + char *name; + struct sexp_gc_var_t *next; +}; + +struct sexp_struct { + sexp_tag_t tag; + char immutablep; + char gc_mark; + union { + /* basic types */ + double flonum; + struct { + sexp_tag_t tag; + short field_base, field_len_base, field_len_off, field_len_scale; + short size_base, size_off, size_scale; + char *name; + } type; + struct { + sexp car, cdr; + sexp source; + } pair; + struct { + sexp_uint_t length; + sexp data[]; + } vector; + struct { + sexp_uint_t length; + char data[]; + } string; + struct { + sexp string; + } symbol; + struct { + FILE *stream; + char *buf; + sexp_uint_t offset, line, size, openp, sourcep; + sexp name; + sexp cookie; + } port; + struct { + sexp kind, message, irritants, procedure, source; + } exception; + struct { + char sign; + sexp_uint_t length; + sexp_uint_t data[]; + } bignum; + /* runtime types */ + struct { + char flags; + sexp parent, lambda, bindings; + } env; + struct { + sexp_uint_t length; + sexp name, literals; + unsigned char data[]; + } bytecode; + struct { + char flags; + unsigned short num_args; + sexp bc, vars; + } procedure; + struct { + sexp proc, env; + } macro; + struct { + sexp env, free_vars, expr; + } synclo; + struct { + unsigned char op_class, code, num_args, flags, + arg1_type, arg2_type, inverse; + char *name; + sexp data, dflt, proc; + } opcode; + struct { + char code; + char *name; + } core; + /* ast types */ + struct { + sexp name, params, locals, defs, flags, fv, sv, body; + } lambda; + struct { + sexp test, pass, fail; + } cnd; + struct { + sexp var, value; + } set; + struct { + sexp name, cell; + } ref; + struct { + sexp ls; + } seq; + struct { + sexp value; + } lit; + /* compiler state */ + struct { + sexp_uint_t length, top; + sexp data[]; + } stack; + struct { + struct sexp_gc_var_t *saves; + sexp_uint_t pos, depth, tailp, tracep; + sexp bc, lambda, stack, env, fv, parent; + } context; + } value; +}; + +#define SEXP_MAKE_IMMEDIATE(n) ((sexp) ((n<value.x)) + +#define sexp_offsetof(type, f) (offsetof(struct sexp_struct, value.type.f)) + +#define sexp_alloc_type(ctx, type, tag) sexp_alloc_tagged(ctx, sexp_sizeof(type), tag) + +/***************************** predicates *****************************/ + +#define sexp_truep(x) ((x) != SEXP_FALSE) +#define sexp_not(x) ((x) == SEXP_FALSE) + +#define sexp_nullp(x) ((x) == SEXP_NULL) +#define sexp_pointerp(x) (((sexp_uint_t)(x) & SEXP_FIXNUM_MASK) == SEXP_POINTER_TAG) +#define sexp_integerp(x) (((sexp_uint_t)(x) & SEXP_FIXNUM_MASK) == SEXP_FIXNUM_TAG) +#define sexp_isymbolp(x) (((sexp_uint_t)(x) & SEXP_IMMEDIATE_MASK) == SEXP_ISYMBOL_TAG) +#define sexp_charp(x) (((sexp_uint_t)(x) & SEXP_EXTENDED_MASK) == SEXP_CHAR_TAG) +#define sexp_booleanp(x) (((x) == SEXP_TRUE) || ((x) == SEXP_FALSE)) + +#define sexp_pointer_tag(x) ((x)->tag) +#define sexp_gc_mark(x) ((x)->gc_mark) +#define sexp_immutablep(x) ((x)->immutablep) + +#define sexp_check_tag(x,t) (sexp_pointerp(x) && (sexp_pointer_tag(x) == (t))) + +#if USE_IMMEDIATE_FLONUMS +union sexp_flonum_conv { + float flonum; + sexp_uint_t bits; +}; +#define sexp_flonump(x) (((sexp_uint_t)(x) & SEXP_IMMEDIATE_MASK) == SEXP_IFLONUM_TAG) +#define sexp_make_flonum(ctx, x) ((sexp) ((((union sexp_flonum_conv)((float)(x))).bits & ~SEXP_IMMEDIATE_MASK) + SEXP_IFLONUM_TAG)) +#define sexp_flonum_value(x) (((union sexp_flonum_conv)(((sexp_uint_t)(x)) & ~SEXP_IMMEDIATE_MASK)).flonum) +#else +#define sexp_flonump(x) (sexp_check_tag(x, SEXP_FLONUM)) +#define sexp_flonum_value(f) ((f)->value.flonum) +sexp sexp_make_flonum(sexp ctx, double f); +#endif + +#define sexp_typep(x) (sexp_check_tag(x, SEXP_TYPE)) +#define sexp_pairp(x) (sexp_check_tag(x, SEXP_PAIR)) +#define sexp_stringp(x) (sexp_check_tag(x, SEXP_STRING)) +#define sexp_lsymbolp(x) (sexp_check_tag(x, SEXP_SYMBOL)) +#define sexp_vectorp(x) (sexp_check_tag(x, SEXP_VECTOR)) +#define sexp_iportp(x) (sexp_check_tag(x, SEXP_IPORT)) +#define sexp_oportp(x) (sexp_check_tag(x, SEXP_OPORT)) +#define sexp_exceptionp(x) (sexp_check_tag(x, SEXP_EXCEPTION)) +#define sexp_procedurep(x) (sexp_check_tag(x, SEXP_PROCEDURE)) +#define sexp_envp(x) (sexp_check_tag(x, SEXP_ENV)) +#define sexp_bytecodep(x) (sexp_check_tag(x, SEXP_BYTECODE)) +#define sexp_corep(x) (sexp_check_tag(x, SEXP_CORE)) +#define sexp_opcodep(x) (sexp_check_tag(x, SEXP_OPCODE)) +#define sexp_macrop(x) (sexp_check_tag(x, SEXP_MACRO)) +#define sexp_synclop(x) (sexp_check_tag(x, SEXP_SYNCLO)) +#define sexp_lambdap(x) (sexp_check_tag(x, SEXP_LAMBDA)) +#define sexp_cndp(x) (sexp_check_tag(x, SEXP_CND)) +#define sexp_refp(x) (sexp_check_tag(x, SEXP_REF)) +#define sexp_setp(x) (sexp_check_tag(x, SEXP_SET)) +#define sexp_seqp(x) (sexp_check_tag(x, SEXP_SEQ)) +#define sexp_litp(x) (sexp_check_tag(x, SEXP_LIT)) +#define sexp_contextp(x) (sexp_check_tag(x, SEXP_CONTEXT)) +#define sexp_symbolp(x) (sexp_isymbolp(x) || sexp_lsymbolp(x)) + +#define sexp_idp(x) \ + (sexp_symbolp(x) || (sexp_synclop(x) && sexp_symbolp(sexp_synclo_expr(x)))) + +#define sexp_portp(x) (sexp_iportp(x) || sexp_oportp(x)) + +/***************************** constructors ****************************/ + +#define sexp_make_boolean(x) ((x) ? SEXP_TRUE : SEXP_FALSE) +#define sexp_unbox_boolean(x) (((x) == SEXP_FALSE) ? 0 : 1) + +#define sexp_make_integer(n) ((sexp) ((((sexp_sint_t)(n))<>SEXP_FIXNUM_BITS) + +#define sexp_make_character(n) ((sexp) ((((sexp_sint_t)(n))<>SEXP_EXTENDED_BITS)) + +#if USE_FLONUMS +#define sexp_integer_to_flonum(ctx, x) (sexp_make_flonum(ctx, sexp_unbox_integer(x))) +#else +#define sexp_integer_to_flonum(ctx, x) (x) +#endif + +/*************************** field accessors **************************/ + +#define sexp_vector_length(x) ((x)->value.vector.length) +#define sexp_vector_data(x) ((x)->value.vector.data) + +#define sexp_vector_ref(x,i) (sexp_vector_data(x)[sexp_unbox_integer(i)]) +#define sexp_vector_set(x,i,v) (sexp_vector_data(x)[sexp_unbox_integer(i)]=(v)) + +#define sexp_procedure_num_args(x) ((x)->value.procedure.num_args) +#define sexp_procedure_flags(x) ((x)->value.procedure.flags) +#define sexp_procedure_variadic_p(x) (sexp_unbox_integer(sexp_procedure_flags(x)) & 1) +#define sexp_procedure_code(x) ((x)->value.procedure.bc) +#define sexp_procedure_vars(x) ((x)->value.procedure.vars) + +#define sexp_string_length(x) ((x)->value.string.length) +#define sexp_string_data(x) ((x)->value.string.data) + +#define sexp_string_ref(x, i) (sexp_make_character(sexp_string_data(x)[sexp_unbox_integer(i)])) +#define sexp_string_set(x, i, v) (sexp_string_data(x)[sexp_unbox_integer(i)] = sexp_unbox_character(v)) + +#define sexp_symbol_string(x) ((x)->value.symbol.string) + +#define sexp_port_stream(p) ((p)->value.port.stream) +#define sexp_port_name(p) ((p)->value.port.name) +#define sexp_port_line(p) ((p)->value.port.line) +#define sexp_port_openp(p) ((p)->value.port.openp) +#define sexp_port_sourcep(p) ((p)->value.port.sourcep) +#define sexp_port_cookie(p) ((p)->value.port.cookie) +#define sexp_port_buf(p) ((p)->value.port.buf) +#define sexp_port_size(p) ((p)->value.port.size) +#define sexp_port_offset(p) ((p)->value.port.offset) + +#define sexp_exception_kind(p) ((p)->value.exception.kind) +#define sexp_exception_message(p) ((p)->value.exception.message) +#define sexp_exception_irritants(p) ((p)->value.exception.irritants) +#define sexp_exception_procedure(p) ((p)->value.exception.procedure) +#define sexp_exception_source(p) ((p)->value.exception.source) + +#define sexp_bytecode_length(x) ((x)->value.bytecode.length) +#define sexp_bytecode_name(x) ((x)->value.bytecode.name) +#define sexp_bytecode_literals(x) ((x)->value.bytecode.literals) +#define sexp_bytecode_data(x) ((x)->value.bytecode.data) + +#define sexp_env_flags(x) ((x)->value.env.flags) +#define sexp_env_parent(x) ((x)->value.env.parent) +#define sexp_env_bindings(x) ((x)->value.env.bindings) +#define sexp_env_local_p(x) (sexp_env_parent(x)) +#define sexp_env_global_p(x) (! sexp_env_local_p(x)) +#define sexp_env_lambda(x) ((x)->value.env.lambda) + +#define sexp_macro_proc(x) ((x)->value.macro.proc) +#define sexp_macro_env(x) ((x)->value.macro.env) + +#define sexp_synclo_env(x) ((x)->value.synclo.env) +#define sexp_synclo_free_vars(x) ((x)->value.synclo.free_vars) +#define sexp_synclo_expr(x) ((x)->value.synclo.expr) + +#define sexp_core_code(x) ((x)->value.core.code) +#define sexp_core_name(x) ((x)->value.core.name) + +#define sexp_opcode_class(x) ((x)->value.opcode.op_class) +#define sexp_opcode_code(x) ((x)->value.opcode.code) +#define sexp_opcode_num_args(x) ((x)->value.opcode.num_args) +#define sexp_opcode_flags(x) ((x)->value.opcode.flags) +#define sexp_opcode_arg1_type(x) ((x)->value.opcode.arg1_type) +#define sexp_opcode_arg2_type(x) ((x)->value.opcode.arg2_type) +#define sexp_opcode_inverse(x) ((x)->value.opcode.inverse) +#define sexp_opcode_name(x) ((x)->value.opcode.name) +#define sexp_opcode_default(x) ((x)->value.opcode.dflt) +#define sexp_opcode_data(x) ((x)->value.opcode.data) +#define sexp_opcode_proc(x) ((x)->value.opcode.proc) + +#define sexp_opcode_variadic_p(x) (sexp_opcode_flags(x) & 1) +#define sexp_opcode_opt_param_p(x) (sexp_opcode_flags(x) & 2) + +#define sexp_lambda_name(x) ((x)->value.lambda.name) +#define sexp_lambda_params(x) ((x)->value.lambda.params) +#define sexp_lambda_locals(x) ((x)->value.lambda.locals) +#define sexp_lambda_defs(x) ((x)->value.lambda.defs) +#define sexp_lambda_flags(x) ((x)->value.lambda.flags) +#define sexp_lambda_body(x) ((x)->value.lambda.body) +#define sexp_lambda_fv(x) ((x)->value.lambda.fv) +#define sexp_lambda_sv(x) ((x)->value.lambda.sv) + +#define sexp_cnd_test(x) ((x)->value.cnd.test) +#define sexp_cnd_pass(x) ((x)->value.cnd.pass) +#define sexp_cnd_fail(x) ((x)->value.cnd.fail) + +#define sexp_set_var(x) ((x)->value.set.var) +#define sexp_set_value(x) ((x)->value.set.value) + +#define sexp_ref_name(x) ((x)->value.ref.name) +#define sexp_ref_cell(x) ((x)->value.ref.cell) +#define sexp_ref_loc(x) (sexp_cdr(sexp_ref_cell(x))) + +#define sexp_seq_ls(x) ((x)->value.seq.ls) + +#define sexp_lit_value(x) ((x)->value.lit.value) + +#define sexp_stack_length(x) ((x)->value.stack.length) +#define sexp_stack_top(x) ((x)->value.stack.top) +#define sexp_stack_data(x) ((x)->value.stack.data) + +#define sexp_context_heap(x) ((x)->value.context.heap) +#define sexp_context_symbols(x) ((x)->value.context.symbols) +#define sexp_context_env(x) ((x)->value.context.env) +#define sexp_context_stack(x) ((x)->value.context.stack) +#define sexp_context_depth(x) ((x)->value.context.depth) +#define sexp_context_bc(x) ((x)->value.context.bc) +#define sexp_context_fv(x) ((x)->value.context.fv) +#define sexp_context_pos(x) ((x)->value.context.pos) +#define sexp_context_lambda(x) ((x)->value.context.lambda) +#define sexp_context_parent(x) ((x)->value.context.parent) +#define sexp_context_saves(x) ((x)->value.context.saves) +#define sexp_context_tailp(x) ((x)->value.context.tailp) +#define sexp_context_tracep(x) ((x)->value.context.tailp) + +#define sexp_context_top(x) (sexp_stack_top(sexp_context_stack(x))) + +#define sexp_type_tag(x) ((x)->value.type.tag) +#define sexp_type_field_base(x) ((x)->value.type.field_base) +#define sexp_type_field_len_base(x) ((x)->value.type.field_len_base) +#define sexp_type_field_len_off(x) ((x)->value.type.field_len_off) +#define sexp_type_field_len_scale(x) ((x)->value.type.field_len_scale) +#define sexp_type_size_base(x) ((x)->value.type.size_base) +#define sexp_type_size_off(x) ((x)->value.type.size_off) +#define sexp_type_size_scale(x) ((x)->value.type.size_scale) +#define sexp_type_name(x) ((x)->value.type.name) + +#define sexp_bignum_sign(x) ((x)->value.bignum.sign) +#define sexp_bignum_length(x) ((x)->value.bignum.length) +#define sexp_bignum_data(x) ((x)->value.bignum.data) + +/****************************** arithmetic ****************************/ + +#define sexp_fx_add(a, b) ((sexp)(((sexp_sint_t)a)+((sexp_sint_t)b)-SEXP_FIXNUM_TAG)) +#define sexp_fx_sub(a, b) ((sexp)(((sexp_sint_t)a)-((sexp_sint_t)b)+SEXP_FIXNUM_TAG)) +#define sexp_fx_mul(a, b) ((sexp)((((((sexp_sint_t)a)-SEXP_FIXNUM_TAG)*(((sexp_sint_t)b)>>SEXP_FIXNUM_BITS))+SEXP_FIXNUM_TAG))) +#define sexp_fx_div(a, b) (sexp_make_integer(sexp_unbox_integer(a) / sexp_unbox_integer(b))) +#define sexp_fx_rem(a, b) (sexp_make_integer(sexp_unbox_integer(a) % sexp_unbox_integer(b))) +#define sexp_fx_sign(a) (-((sexp_sint_t)(a) < 0)) /* -1 or 0 */ + +#define sexp_fp_add(x,a,b) (sexp_make_flonum(x, sexp_flonum_value(a) + sexp_flonum_value(b))) +#define sexp_fp_sub(x,a,b) (sexp_make_flonum(x, sexp_flonum_value(a) - sexp_flonum_value(b))) +#define sexp_fp_mul(x,a,b) (sexp_make_flonum(x, sexp_flonum_value(a) * sexp_flonum_value(b))) +#define sexp_fp_div(x,a,b) (sexp_make_flonum(x, sexp_flonum_value(a) / sexp_flonum_value(b))) + +/****************************** utilities *****************************/ + +#define sexp_list1(x,a) sexp_cons((x), (a), SEXP_NULL) + +#define sexp_push(ctx, ls, x) ((ls) = sexp_cons((ctx), (x), (ls))) +#define sexp_insert(ctx, ls, x) ((sexp_memq(NULL, (x), (ls)) != SEXP_FALSE) ? (ls) : sexp_push((ctx), (ls), (x))) + +#define sexp_pair_source(x) ((x)->value.pair.source) + +#define sexp_car(x) ((x)->value.pair.car) +#define sexp_cdr(x) ((x)->value.pair.cdr) + +#define sexp_caar(x) (sexp_car(sexp_car(x))) +#define sexp_cadr(x) (sexp_car(sexp_cdr(x))) +#define sexp_cdar(x) (sexp_cdr(sexp_car(x))) +#define sexp_cddr(x) (sexp_cdr(sexp_cdr(x))) +#define sexp_caaar(x) (sexp_car(sexp_caar(x))) +#define sexp_caadr(x) (sexp_car(sexp_cadr(x))) +#define sexp_cadar(x) (sexp_car(sexp_cdar(x))) +#define sexp_caddr(x) (sexp_car(sexp_cddr(x))) +#define sexp_cdaar(x) (sexp_cdr(sexp_caar(x))) +#define sexp_cdadr(x) (sexp_cdr(sexp_cadr(x))) +#define sexp_cddar(x) (sexp_cdr(sexp_cdar(x))) +#define sexp_cdddr(x) (sexp_cdr(sexp_cddr(x))) +#define sexp_cadddr(x) (sexp_cadr(sexp_cddr(x))) /* just these two */ +#define sexp_cddddr(x) (sexp_cddr(sexp_cddr(x))) + +/***************************** general API ****************************/ + +#if USE_STRING_STREAMS + +#define sexp_read_char(x, p) (getc(sexp_port_stream(p))) +#define sexp_push_char(x, c, p) (ungetc(c, sexp_port_stream(p))) +#define sexp_write_char(x, c, p) (putc(c, sexp_port_stream(p))) +#define sexp_write_string(x, s, p) (fputs(s, sexp_port_stream(p))) +#define sexp_printf(x, p, ...) (fprintf(sexp_port_stream(p), __VA_ARGS__)) +#define sexp_flush(x, p) (fflush(sexp_port_stream(p))) + +#else + +#define sexp_read_char(x, p) (sexp_port_buf(p) ? ((sexp_port_offset(p) < sexp_port_size(p)) ? sexp_port_buf(p)[sexp_port_offset(p)++] : sexp_buffered_read_char(x, p)) : getc(sexp_port_stream(p))) +#define sexp_push_char(x, c, p) (sexp_port_buf(p) ? (sexp_port_buf(p)[--sexp_port_offset(p)] = ((char)(c))) : ungetc(c, sexp_port_stream(p))) +#define sexp_write_char(x, c, p) (sexp_port_buf(p) ? ((sexp_port_offset(p) < sexp_port_size(p)) ? ((((sexp_port_buf(p))[sexp_port_offset(p)++]) = (char)(c)), SEXP_VOID) : sexp_buffered_write_char(x, c, p)) : (putc(c, sexp_port_stream(p)), SEXP_VOID)) +#define sexp_write_string(x, s, p) (sexp_port_buf(p) ? sexp_buffered_write_string(x, s, p) : (fputs(s, sexp_port_stream(p)), SEXP_VOID)) +#define sexp_flush(x, p) (sexp_port_buf(p) ? sexp_buffered_flush(x, p) : (fflush(sexp_port_stream(p)), SEXP_VOID)) + +int sexp_buffered_read_char (sexp ctx, sexp p); +sexp sexp_buffered_write_char (sexp ctx, int c, sexp p); +sexp sexp_buffered_write_string_n (sexp ctx, char *str, sexp_uint_t len, sexp p); +sexp sexp_buffered_write_string (sexp ctx, char *str, sexp p); +sexp sexp_buffered_flush (sexp ctx, sexp p); + +#endif + +#define sexp_newline(ctx, p) sexp_write_char(ctx, '\n', (p)) + +sexp sexp_alloc_tagged(sexp ctx, size_t size, sexp_uint_t tag); +sexp sexp_cons(sexp ctx, sexp head, sexp tail); +sexp sexp_list2(sexp ctx, sexp a, sexp b); +sexp sexp_equalp (sexp ctx, sexp a, sexp b); +sexp sexp_listp(sexp ctx, sexp obj); +sexp sexp_reverse(sexp ctx, sexp ls); +sexp sexp_nreverse(sexp ctx, sexp ls); +sexp sexp_append2(sexp ctx, sexp a, sexp b); +sexp sexp_memq(sexp ctx, sexp x, sexp ls); +sexp sexp_assq(sexp ctx, sexp x, sexp ls); +sexp sexp_length(sexp ctx, sexp ls); +sexp sexp_c_string(sexp ctx, char *str, sexp_sint_t slen); +sexp sexp_make_string(sexp ctx, sexp len, sexp ch); +sexp sexp_substring (sexp ctx, sexp str, sexp start, sexp end); +sexp sexp_string_concatenate (sexp ctx, sexp str_ls); +sexp sexp_intern(sexp ctx, char *str); +sexp sexp_string_to_symbol(sexp ctx, sexp str); +sexp sexp_make_vector(sexp ctx, sexp len, sexp dflt); +sexp sexp_list_to_vector(sexp ctx, sexp ls); +void sexp_write(sexp ctx, sexp obj, sexp out); +sexp sexp_read_string(sexp ctx, sexp in); +sexp sexp_read_symbol(sexp ctx, sexp in, int init, int internp); +sexp sexp_read_number(sexp ctx, sexp in, int base); +sexp sexp_read_raw(sexp ctx, sexp in); +sexp sexp_read(sexp ctx, sexp in); +sexp sexp_read_from_string(sexp ctx, char *str); +sexp sexp_make_input_port(sexp ctx, FILE* in, sexp name); +sexp sexp_make_output_port(sexp ctx, FILE* out, sexp name); +sexp sexp_make_input_string_port(sexp ctx, sexp str); +sexp sexp_make_output_string_port(sexp ctx); +sexp sexp_get_output_string(sexp ctx, sexp port); +sexp sexp_make_exception(sexp ctx, sexp kind, sexp message, sexp irritants, sexp procedure, sexp source); +sexp sexp_user_exception (sexp ctx, sexp self, char *message, sexp obj); +sexp sexp_type_exception (sexp ctx, char *message, sexp obj); +sexp sexp_range_exception (sexp ctx, sexp obj, sexp start, sexp end); +sexp sexp_print_exception(sexp ctx, sexp exn, sexp out); +void sexp_init(); + +#endif /* ! SEXP_H */ + diff --git a/init.scm b/init.scm new file mode 100644 index 00000000..08d321c1 --- /dev/null +++ b/init.scm @@ -0,0 +1,713 @@ + +;; provide c[ad]{2,4}r + +(define (caar x) (car (car x))) +(define (cadr x) (car (cdr x))) +(define (cdar x) (cdr (car x))) +(define (cddr x) (cdr (cdr x))) +(define (caaar x) (car (car (car x)))) +(define (caadr x) (car (car (cdr x)))) +(define (cadar x) (car (cdr (car x)))) +(define (caddr x) (car (cdr (cdr x)))) +(define (cdaar x) (cdr (car (car x)))) +(define (cdadr x) (cdr (car (cdr x)))) +(define (cddar x) (cdr (cdr (car x)))) +(define (cdddr x) (cdr (cdr (cdr x)))) +(define (caaaar x) (car (car (car (car x))))) +(define (caaadr x) (car (car (car (cdr x))))) +(define (caadar x) (car (car (cdr (car x))))) +(define (caaddr x) (car (car (cdr (cdr x))))) +(define (cadaar x) (car (cdr (car (car x))))) +(define (cadadr x) (car (cdr (car (cdr x))))) +(define (caddar x) (car (cdr (cdr (car x))))) +(define (cadddr x) (car (cdr (cdr (cdr x))))) +(define (cdaaar x) (cdr (car (car (car x))))) +(define (cdaadr x) (cdr (car (car (cdr x))))) +(define (cdadar x) (cdr (car (cdr (car x))))) +(define (cdaddr x) (cdr (car (cdr (cdr x))))) +(define (cddaar x) (cdr (cdr (car (car x))))) +(define (cddadr x) (cdr (cdr (car (cdr x))))) +(define (cdddar x) (cdr (cdr (cdr (car x))))) +(define (cddddr x) (cdr (cdr (cdr (cdr x))))) + +;; basic utils + +(define (procedure? x) (if (closure? x) #t (opcode? x))) + +(define (list . args) args) + +(define (list-tail ls k) + (if (eq? k 0) + ls + (list-tail (cdr ls) (- k 1)))) + +(define (list-ref ls k) (car (list-tail ls k))) + +(define (append-helper ls res) + (if (null? ls) + res + (append-helper (cdr ls) (append2 (car ls) res)))) + +(define (append . o) + (if (null? o) + '() + ((lambda (lol) + (append-helper (cdr lol) (car lol))) + (reverse o)))) + +(define (apply proc . args) + (if (null? args) + (proc) + ((lambda (lol) + (apply1 proc (append2 (reverse (cdr lol)) (car lol)))) + (reverse args)))) + +;; map with a fast-path for single lists + +(define (map proc ls . lol) + (define (map1 proc ls res) + (if (pair? ls) + (map1 proc (cdr ls) (cons (proc (car ls)) res)) + (reverse res))) + (define (mapn proc lol res) + (if (null? (car lol)) + (reverse res) + (mapn proc + (map1 cdr lol '()) + (cons (apply1 proc (map1 car lol '())) res)))) + (if (null? lol) + (map1 proc ls '()) + (mapn proc (cons ls lol) '()))) + +(define for-each map) + +(define (any pred ls) + (if (pair? ls) (if (pred (car ls)) #t (any pred (cdr ls))) #f)) + +;; syntax + +(define sc-macro-transformer + (lambda (f) + (lambda (expr use-env mac-env) + (make-syntactic-closure mac-env '() (f expr use-env))))) + +(define rsc-macro-transformer + (lambda (f) + (lambda (expr use-env mac-env) + (make-syntactic-closure use-env '() (f expr mac-env))))) + +(define er-macro-transformer + (lambda (f) + (lambda (expr use-env mac-env) + ((lambda (rename compare) (f expr rename compare)) + ((lambda (renames) + (lambda (identifier) + ((lambda (cell) + (if cell + (cdr cell) + ((lambda (name) + (set! renames (cons (cons identifier name) renames)) + name) + (make-syntactic-closure mac-env '() identifier)))) + (assq identifier renames)))) + '()) + (lambda (x y) (identifier=? use-env x use-env y)))))) + +(define-syntax cond + (er-macro-transformer + (lambda (expr rename compare) + (if (null? (cdr expr)) + #f + ((lambda (cl) + (if (compare 'else (car cl)) + (cons (rename 'begin) (cdr cl)) + (if (if (null? (cdr cl)) #t (compare '=> (cadr cl))) + (list (list (rename 'lambda) (list (rename 'tmp)) + (list (rename 'if) (rename 'tmp) + (if (null? (cdr cl)) + (rename 'tmp) + (list (caddr cl) (rename 'tmp))) + (cons (rename 'cond) (cddr expr)))) + (car cl)) + (list (rename 'if) + (car cl) + (cons (rename 'begin) (cdr cl)) + (cons (rename 'cond) (cddr expr)))))) + (cadr expr)))))) + +(define-syntax or + (er-macro-transformer + (lambda (expr rename compare) + (cond ((null? (cdr expr)) #f) + ((null? (cddr expr)) (cadr expr)) + (else + (list (rename 'let) (list (list (rename 'tmp) (cadr expr))) + (list (rename 'if) (rename 'tmp) + (rename 'tmp) + (cons (rename 'or) (cddr expr))))))))) + +(define-syntax and + (er-macro-transformer + (lambda (expr rename compare) + (cond ((null? (cdr expr))) + ((null? (cddr expr)) (cadr expr)) + (else (list (rename 'if) (cadr expr) + (cons (rename 'and) (cddr expr)) + #f)))))) + +(define-syntax quasiquote + (er-macro-transformer + (lambda (expr rename compare) + (define (qq x d) + (cond + ((pair? x) + (cond + ((eq? 'unquote (car x)) + (if (<= d 0) + (cadr x) + (list (rename 'list) (list (rename 'quote) 'unquote) + (qq (cadr x) (- d 1))))) + ((eq? 'unquote-splicing (car x)) + (if (<= d 0) + (list (rename 'cons) (qq (car x) d) (qq (cdr x) d)) + (list (rename 'list) (list (rename 'quote) 'unquote-splicing) + (qq (cadr x) (- d 1))))) + ((eq? 'quasiquote (car x)) + (list (rename 'list) (list (rename 'quote) 'quasiquote) + (qq (cadr x) (+ d 1)))) + ((and (<= d 0) (pair? (car x)) (eq? 'unquote-splicing (caar x))) + (if (null? (cdr x)) + (cadar x) + (list (rename 'append) (cadar x) (qq (cdr x) d)))) + (else + (list (rename 'cons) (qq (car x) d) (qq (cdr x) d))))) + ((vector? x) (list (rename 'list->vector) (qq (vector->list x) d))) + ((symbol? x) (list (rename 'quote) x)) + (else x))) + (qq (cadr expr) 0)))) + +(define-syntax letrec + (er-macro-transformer + (lambda (expr rename compare) + ((lambda (defs) + `((,(rename 'lambda) () ,@defs ,@(cddr expr)))) + (map (lambda (x) (cons (rename 'define) x)) (cadr expr)))))) + +(define-syntax let + (er-macro-transformer + (lambda (expr rename compare) + (if (identifier? (cadr expr)) + `(,(rename 'letrec) ((,(cadr expr) + (,(rename 'lambda) ,(map car (caddr expr)) + ,@(cdddr expr)))) + ,(cons (cadr expr) (map cadr (caddr expr)))) + `((,(rename 'lambda) ,(map car (cadr expr)) ,@(cddr expr)) + ,@(map cadr (cadr expr))))))) + +(define-syntax let* + (er-macro-transformer + (lambda (expr rename compare) + (if (null? (cadr expr)) + `(,(rename 'begin) ,@(cddr expr)) + `(,(rename 'let) (,(caadr expr)) + (,(rename 'let*) ,(cdadr expr) ,@(cddr expr))))))) + +(define-syntax case + (er-macro-transformer + (lambda (expr rename compare) + (define (clause ls) + (cond + ((null? ls) #f) + ((compare 'else (caar ls)) + `(,(rename 'begin) ,@(cdar ls))) + (else + (if (and (pair? (caar ls)) (null? (cdaar ls))) + `(,(rename 'if) (,(rename 'eqv?) ,(rename 'tmp) ',(caaar ls)) + (,(rename 'begin) ,@(cdar ls)) + ,(clause (cdr ls))) + `(,(rename 'if) (,(rename 'memv) ,(rename 'tmp) ',(caar ls)) + (,(rename 'begin) ,@(cdar ls)) + ,(clause (cdr ls))))))) + `(let ((,(rename 'tmp) ,(cadr expr))) + ,(clause (cddr expr)))))) + +(define-syntax do + (er-macro-transformer + (lambda (expr rename compare) + (let* ((body + `(,(rename 'begin) + ,@(cdddr expr) + (,(rename 'lp) + ,@(map (lambda (x) (if (pair? (cddr x)) (caddr x) (car x))) + (cadr expr))))) + (check (caddr expr)) + (wrap + (if (null? (cdr check)) + `(,(rename 'let) ((,(rename 'tmp) ,(car check))) + (,(rename 'if) ,(rename 'tmp) + ,(rename 'tmp) + ,body)) + `(,(rename 'if) ,(car check) + (,(rename 'begin) ,@(cdr check)) + ,body)))) + `(,(rename 'let) ,(rename 'lp) + ,(map (lambda (x) (list (car x) (cadr x))) (cadr expr)) + ,wrap))))) + +(define-syntax delay + (er-macro-transformer + (lambda (expr rename compare) + `(,(rename 'make-promise) (,(rename 'lambda) () ,(cadr expr)))))) + +(define (make-promise thunk) + (lambda () + (let ((computed? #f) (result #f)) + (if (not computed?) + (begin + (set! result (thunk)) + (set! computed? #t))) + result))) + +(define (force x) (if (procedure? x) (x) x)) + +(define (error msg . args) + (raise (make-exception 'user msg args #f #f #f))) + +(define (with-exception-handler handler thunk) + (let ((orig-handler (current-exception-handler))) + (current-exception-handler handler) + (let ((res (thunk))) + (current-exception-handler orig-handler) + res))) + +;; booleans + +(define (not x) (if x #f #t)) +(define (boolean? x) (if (eq? x #t) #t (eq? x #f))) + +;; char utils + +(define (char-alphabetic? ch) (<= 65 (char->integer (char-upcase ch)) 90)) +(define (char-numeric? ch) (<= 48 (char->integer ch) 57)) +(define (char-whitespace? ch) + (if (eq? ch #\space) + #t + (if (eq? ch #\tab) #t (if (eq? ch #\newline) #t (eq? ch #\return))))) +(define (char-upper-case? ch) (<= 65 (char->integer ch) 90)) +(define (char-lower-case? ch) (<= 97 (char->integer ch) 122)) + +(define (char=? a b) (= (char->integer a) (char->integer b))) +(define (charinteger a) (char->integer b))) +(define (char>? a b) (> (char->integer a) (char->integer b))) +(define (char<=? a b) (<= (char->integer a) (char->integer b))) +(define (char>=? a b) (>= (char->integer a) (char->integer b))) + +(define (char-ci=? a b) + (= (char->integer (char-downcase a)) (char->integer (char-downcase b)))) +(define (char-ciinteger (char-downcase a)) (char->integer (char-downcase b)))) +(define (char-ci>? a b) + (> (char->integer (char-downcase a)) (char->integer (char-downcase b)))) +(define (char-ci<=? a b) + (<= (char->integer (char-downcase a)) (char->integer (char-downcase b)))) +(define (char-ci>=? a b) + (>= (char->integer (char-downcase a)) (char->integer (char-downcase b)))) + +;; string utils + +(define (symbol->string sym) + (call-with-output-string (lambda (out) (write sym out)))) + +(define (list->string ls) + (let ((str (make-string (length ls) #\space))) + (let lp ((ls ls) (i 0)) + (if (pair? ls) + (begin + (string-set! str i (car ls)) + (lp (cdr ls) (+ i 1))))) + str)) + +(define (string->list str) + (let lp ((i (- (string-length str) 1)) (res '())) + (if (< i 0) res (lp (- i 1) (cons (string-ref str i) res))))) + +(define (string-fill! str ch) + (let lp ((i (- (string-length str) 1))) + (if (>= i 0) (begin (string-set! str i ch) (lp (- i 1)))))) + +(define (string . args) (list->string args)) +(define (string-append . args) (string-concatenate args)) +(define (string-copy s) (substring s 0 (string-length s))) + +(define (string=? s1 s2) (eq? (string-cmp s1 s2 #f) 0)) +(define (string? s1 s2) (> (string-cmp s1 s2 #f) 0)) +(define (string>=? s1 s2) (>= (string-cmp s1 s2 #f) 0)) + +(define (string-ci=? s1 s2) (eq? (string-cmp s1 s2 #t) 0)) +(define (string-ci? s1 s2) (> (string-cmp s1 s2 #t) 0)) +(define (string-ci>=? s1 s2) (>= (string-cmp s1 s2 #t) 0)) + +;; list utils + +(define (eqv? a b) (if (eq? a b) #t (and (flonum? a) (flonum? b) (= a b)))) + +(define (member obj ls) + (if (null? ls) + #f + (if (equal? obj (car ls)) + ls + (member obj (cdr ls))))) + +(define memv member) + +(define (assoc obj ls) + (if (null? ls) + #f + (if (equal? obj (caar ls)) + (car ls) + (assoc obj (cdr ls))))) + +(define assv assoc) + +;; math utils + +(define (number? x) (if (fixnum? x) #t (flonum? x))) +(define complex? number?) +(define rational? number?) +(define real? number?) +(define exact? fixnum?) +(define inexact? flonum?) +(define (integer? x) (if (fixnum? x) #t (and (flonum? x) (= x (truncate x))))) + +(define (zero? x) (= x 0)) +(define (positive? x) (> x 0)) +(define (negative? x) (< x 0)) +(define (even? n) (= (remainder n 2) 0)) +(define (odd? n) (= (remainder n 2) 1)) + +(define (abs x) (if (< x 0) (- x) x)) + +(define (modulo a b) + (let ((res (remainder a b))) + (if (< b 0) + (if (<= res 0) res (+ res b)) + (if (>= res 0) res (+ res b))))) + +(define (gcd a b) + (if (= b 0) + (abs a) + (gcd b (remainder a b)))) + +(define (lcm a b) + (abs (quotient (* a b) (gcd a b)))) + +(define (max x . rest) + (let lp ((hi x) (ls rest)) + (if (null? ls) + hi + (lp (if (> (car ls) hi) (car ls) hi) (cdr ls))))) + +(define (min x . rest) + (let lp ((lo x) (ls rest)) + (if (null? ls) + lo + (lp (if (< (car ls) lo) (car ls) lo) (cdr ls))))) + +(define (real-part z) z) +(define (imag-part z) 0.0) +(define magnitude abs) +(define (angle z) (if (< z 0) 3.141592653589793 0)) + +(define (atan x . o) (if (null? o) (atan1 x) (atan1 (/ x (car o))))) + +(define (digit-char n) (integer->char (+ n (char->integer #\0)))) +(define (digit-value ch) + (if (char-numeric? ch) + (- (char->integer ch) (char->integer #\0)) + (and (<= 65 (char->integer (char-upcase ch)) 70) + (- (char->integer (char-upcase ch)) 65)))) + +(define (number->string n . o) + (if (if (null? o) #t (eq? 10 (car o))) + (call-with-output-string (lambda (out) (write n out))) + (let lp ((n n) (d (car o)) (res '())) + (if (> n 0) + (lp (quotient n d) d (cons (digit-char (remainder n d)) res)) + (list->string res))))) + +(define (string->number str . o) + (let ((res + (if (if (null? o) #t (eq? 10 (car o))) + (call-with-input-string str (lambda (in) (read in))) + (let ((len (string-length str))) + (let lp ((i 0) (d (car o)) (acc 0)) + (if (>= i len) + acc + (let ((v (digit-value (string-ref str i)))) + (and v (lp (+ i 1) d (+ (* acc d) v)))))))))) + (and (number? res) res))) + +;; vector utils + +(define (list->vector ls) + (let ((vec (make-vector (length ls) #f))) + (let lp ((ls ls) (i 0)) + (if (pair? ls) + (begin + (vector-set! vec i (car ls)) + (lp (cdr ls) (+ i 1))))) + vec)) + +(define (vector->list vec) + (let lp ((i (- (vector-length vec) 1)) (res '())) + (if (< i 0) res (lp (- i 1) (cons (vector-ref vec i) res))))) + +(define (vector-fill! str ch) + (let lp ((i (- (vector-length str) 1))) + (if (>= i 0) (begin (vector-set! str i ch) (lp (- i 1)))))) + +(define (vector . args) (list->vector args)) + +;; I/O utils + +(define (char-ready? . o) + (not (eof-object? (peek-char (if (pair? o) (car o) (current-input-port)))))) + +(define (load file) (%load file (interaction-environment))) + +(define (call-with-input-string str proc) + (let* ((in (open-input-string str)) + (res (proc in))) + (close-input-port in) + res)) + +(define (call-with-output-string proc) + (let ((out (open-output-string))) + (proc out) + (let ((res (get-output-string out))) + (close-output-port out) + res))) + +(define (call-with-input-file file proc) + (let* ((in (open-input-file file)) + (res (proc in))) + (close-input-port in) + res)) + +(define (call-with-output-file file proc) + (let* ((out (open-output-file file)) + (res (proc out))) + (close-output-port out) + res)) + +(define (with-input-from-file file thunk) + (let ((old-in (current-input-port)) + (tmp-in (open-input-file file))) + (current-input-port tmp-in) + (let ((res (thunk))) + (current-input-port old-in) + res))) + +(define (with-output-to-file file thunk) + (let ((old-out (current-input-port)) + (tmp-out (open-output-file file))) + (current-input-port tmp-out) + (let ((res (thunk))) + (current-output-port old-out) + res))) + +;; values + +(define *values-tag* (list 'values)) + +(define (values . ls) + (if (and (pair? ls) (null? (cdr ls))) + (car ls) + (cons *values-tag* ls))) + +(define (call-with-values producer consumer) + (let ((res (producer))) + (if (and (pair? res) (eq? *values-tag* (car res))) + (apply consumer (cdr res)) + (consumer res)))) + +;; syntax-rules + +(define-syntax syntax-rules + (er-macro-transformer + (lambda (expr rename compare) + (let ((lits (cadr expr)) + (forms (cddr expr)) + (count 0) + (_er-macro-transformer (rename 'er-macro-transformer)) + (_lambda (rename 'lambda)) (_let (rename 'let)) + (_begin (rename 'begin)) (_if (rename 'if)) + (_and (rename 'and)) (_or (rename 'or)) + (_eq? (rename 'eq?)) (_equal? (rename 'equal?)) + (_car (rename 'car)) (_cdr (rename 'cdr)) + (_cons (rename 'cons)) (_pair? (rename 'pair?)) + (_null? (rename 'null?)) (_expr (rename 'expr)) + (_rename (rename 'rename)) (_compare (rename 'compare)) + (_quote (rename 'quote)) (_apply (rename 'apply)) + (_append (rename 'append)) (_map (rename 'map)) + (_vector? (rename 'vector?)) (_list? (rename 'list?)) + (_lp (rename 'lp)) (_reverse (rename 'reverse)) + (_vector->list (rename 'vector->list)) + (_list->vector (rename 'list->vector))) + (define (next-v) + (set! count (+ count 1)) + (rename (string->symbol (string-append "v." (number->string count))))) + (define (expand-pattern pat tmpl) + (let lp ((p (cdr pat)) + (x (list _cdr _expr)) + (dim 0) + (vars '()) + (k (lambda (vars) + (or (expand-template tmpl vars) + (list _begin #f))))) + (let ((v (next-v))) + (list + _let (list (list v x)) + (cond + ((identifier? p) + (if (any (lambda (l) (compare p l)) lits) + (list _and (list _compare v (list _quote p)) (k vars)) + (list _let (list (list p v)) (k (cons (cons p dim) vars))))) + ((ellipse? p) + (cond + ((not (null? (cddr p))) + (error "non-trailing ellipse")) + ((identifier? (car p)) + (list _and (list _list? v) + (list _let (list (list (car p) v)) + (k (cons (cons (car p) (+ 1 dim)) vars))))) + (else + (let* ((w (next-v)) + (new-vars (all-vars (car p) (+ dim 1))) + (ls-vars (map (lambda (x) + (rename + (string->symbol + (string-append + (symbol->string + (identifier->symbol (car x))) + "-ls")))) + new-vars)) + (once + (lp (car p) (list _car w) (+ dim 1) '() + (lambda (_) + (cons + _lp + (cons + (list _cdr w) + (map (lambda (x l) + (list _cons (car x) l)) + new-vars + ls-vars))))))) + (list + _let + _lp (cons (list w v) + (map (lambda (x) (list x '())) ls-vars)) + (list _if (list _null? w) + (list _let (map (lambda (x l) + (list (car x) (list _reverse l))) + new-vars + ls-vars) + (k (append new-vars vars))) + (list _and (list _pair? w) once))))))) + ((pair? p) + (list _and (list _pair? v) + (lp (car p) + (list _car v) + dim + vars + (lambda (vars) + (lp (cdr p) (list _cdr v) dim vars k))))) + ((vector? p) + (list _and + (list _vector? v) + (lp (vector->list p) (list _vector->list v) dim vars k))) + ((null? p) (list _and (list _null? v) (k vars))) + (else (list _and (list _equal? v p) (k vars)))))))) + (define (ellipse? x) + (and (pair? x) (pair? (cdr x)) (compare '... (cadr x)))) + (define (ellipse-depth x) + (if (ellipse? x) + (+ 1 (ellipse-depth (cdr x))) + 0)) + (define (ellipse-tail x) + (if (ellipse? x) + (ellipse-tail (cdr x)) + (cdr x))) + (define (all-vars x dim) + (let lp ((x x) (dim dim) (vars '())) + (cond ((identifier? x) (if (memq x (list _quote lits)) + vars + (cons (cons x dim) vars))) + ((ellipse? x) (lp (car x) (+ dim 1) vars)) + ((pair? x) (lp (car x) dim (lp (cdr x) dim vars))) + ((vector? x) (lp (vector->list x) dim vars)) + (else vars)))) + (define (free-vars x vars dim) + (let lp ((x x) (free '())) + (cond + ((identifier? x) + (if (and (not (memq x free)) + (cond ((assq x vars) => (lambda (cell) (>= (cdr cell) dim))) + (else #f))) + (cons x free) + free)) + ((pair? x) (lp (car x) (lp (cdr x) free))) + ((vector? x) (lp (vector->list x) free)) + (else free)))) + (define (expand-template tmpl vars) + (let lp ((t tmpl) (dim 0)) + (cond + ((identifier? t) + (cond + ((assq t vars) + => (lambda (cell) + (if (<= (cdr cell) dim) + t + (error "too few ...'s")))) + (else + (list _rename (list _quote t))))) + ((pair? t) + (if (ellipse? t) + (let* ((depth (ellipse-depth t)) + (ell-dim (+ dim depth)) + (ell-vars (free-vars (car t) vars ell-dim))) + (if (null? ell-vars) + (error "too many ...'s") + (let* ((once (lp (car t) ell-dim)) + (nest (if (and (null? (cdr ell-vars)) + (identifier? once) + (eq? once (car vars))) + once ;; shortcut + (cons _map + (cons (list _lambda ell-vars once) + ell-vars)))) + (many (do ((d depth (- d 1)) + (many nest + (list _apply _append many))) + ((= d 1) many)))) + (if (null? (ellipse-tail t)) + many ;; shortcut + (list _append many (lp (ellipse-tail t) dim)))))) + (list _cons (lp (car t) dim) (lp (cdr t) dim)))) + ((vector? t) (list _list->vector (lp (vector->list t) dim))) + ((null? t) (list _quote '())) + (else t)))) + (list + _er-macro-transformer + (list _lambda (list _expr _rename _compare) + (cons + _or + (append + (map + (lambda (clause) (expand-pattern (car clause) (cadr clause))) + forms) + (list (list 'error "no expansion")))))))))) diff --git a/main.c b/main.c new file mode 100644 index 00000000..1d1f88b9 --- /dev/null +++ b/main.c @@ -0,0 +1,147 @@ +/* main.c -- chibi-scheme command-line app */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#ifndef PLAN9 +#include +#endif +#include "chibi/eval.h" + +char *chibi_module_dir = NULL; + +sexp find_module_file (sexp ctx, char *file) { + sexp res; + int mlen, flen; + char *path; +#ifndef PLAN9 + struct stat buf; + + if (! stat(file, &buf)) +#endif + return sexp_c_string(ctx, file, -1); +#ifndef PLAN9 + if (! chibi_module_dir) { +#ifndef PLAN9 + chibi_module_dir = getenv("CHIBI_MODULE_DIR"); + if (! chibi_module_dir) +#endif + chibi_module_dir = sexp_module_dir; + } + mlen = strlen(chibi_module_dir); + flen = strlen(file); + path = (char*) malloc(mlen+flen+2); + memcpy(path, chibi_module_dir, mlen); + path[mlen] = '/'; + memcpy(path+mlen+1, file, flen); + path[mlen+flen+1] = '\0'; + if (! stat(path, &buf)) + res = sexp_c_string(ctx, path, mlen+flen+2); + else + res = SEXP_FALSE; + free(path); + return res; +#endif +} + +void repl (sexp ctx) { + sexp tmp, res, env, in, out, err; + sexp_gc_var(ctx, obj, s_obj); + sexp_gc_preserve(ctx, obj, s_obj); + env = sexp_context_env(ctx); + sexp_context_tracep(ctx) = 1; + in = sexp_eval_string(ctx, "(current-input-port)"); + out = sexp_eval_string(ctx, "(current-output-port)"); + err = sexp_eval_string(ctx, "(current-error-port)"); + sexp_port_sourcep(in) = 1; + while (1) { + sexp_write_string(ctx, "> ", out); + sexp_flush(ctx, out); + obj = sexp_read(ctx, in); + if (obj == SEXP_EOF) + break; + if (sexp_exceptionp(obj)) { + sexp_print_exception(ctx, obj, err); + } else { + tmp = sexp_env_bindings(env); + sexp_context_top(ctx) = 0; + res = sexp_eval(ctx, obj); +#if USE_WARN_UNDEFS + sexp_warn_undefs(ctx, sexp_env_bindings(env), tmp, err); +#endif + if (res != SEXP_VOID) { + sexp_write(ctx, res, out); + sexp_write_char(ctx, '\n', out); + } + } + } + sexp_gc_release(ctx, obj, s_obj); +} + +void run_main (int argc, char **argv) { + sexp env, out=NULL, res, ctx; + sexp_uint_t i, quit=0, init_loaded=0; + sexp_gc_var(ctx, str, s_str); + + ctx = sexp_make_context(NULL, NULL, NULL); + sexp_gc_preserve(ctx, str, s_str); + env = sexp_context_env(ctx); + out = sexp_eval_string(ctx, "(current-output-port)"); + + /* parse options */ + for (i=1; i < argc && argv[i][0] == '-'; i++) { + switch (argv[i][1]) { + case 'e': + case 'p': + if (! init_loaded++) + sexp_load(ctx, str=find_module_file(ctx, sexp_init_file), env); + res = sexp_read_from_string(ctx, argv[i+1]); + if (! sexp_exceptionp(res)) + res = sexp_eval(ctx, res); + if (sexp_exceptionp(res)) { + sexp_print_exception(ctx, res, out); + quit = 1; + break; + } else if (argv[i][1] == 'p') { + sexp_write(ctx, res, out); + sexp_write_char(ctx, '\n', out); + } + quit=1; + i++; + break; + case 'l': + if (! init_loaded++) + sexp_load(ctx, str=find_module_file(ctx, sexp_init_file), env); + sexp_load(ctx, str=find_module_file(ctx, argv[++i]), env); + break; + case 'q': + init_loaded = 1; + break; + case 'm': + chibi_module_dir = argv[++i]; + break; + default: + errx(1, "unknown option: %s", argv[i]); + } + } + + if (! quit) { + if (! init_loaded) + res = sexp_load(ctx, str=find_module_file(ctx, sexp_init_file), env); + if (! sexp_exceptionp(res)) { + if (i < argc) + for ( ; i < argc; i++) + sexp_load(ctx, str=sexp_c_string(ctx, argv[i], -1), env); + else + repl(ctx); + } + } + + sexp_gc_release(ctx, str, s_str); +} + +int main (int argc, char **argv) { + sexp_scheme_init(); + run_main(argc, argv); + return 0; +} + diff --git a/mkfile b/mkfile new file mode 100644 index 00000000..4de142a2 --- /dev/null +++ b/mkfile @@ -0,0 +1,36 @@ + include/chibi/install.h + +%.i: %.c include/chibi/install.h $HFILES + cpp $CPPFLAGS $stem.c > $target + +sexp.$O: sexp.i + $CC $CFLAGS -c -o $target sexp.i + +eval.$O: eval.i + $CC $CFLAGS -c -o $target eval.i + +main.$O: main.i + $CC $CFLAGS -c -o $target main.i + +chibi-scheme: sexp.$O eval.$O main.$O + $LD -o $target $prereq + +#inexact", 0, NULL), +_OP(OPC_GENERIC, OP_FLO2FIX, 1, 0, 0, 0, 0, "inexact->exact", 0, NULL), +_OP(OPC_GENERIC, OP_CHAR2INT, 1, 0, SEXP_CHAR, 0, 0, "char->integer", 0, NULL), +_OP(OPC_GENERIC, OP_INT2CHAR, 1, 0, SEXP_FIXNUM, 0, 0, "integer->char", 0, NULL), +_OP(OPC_GENERIC, OP_CHAR_UPCASE, 1, 0, SEXP_CHAR, 0, 0, "char-upcase", 0, NULL), +_OP(OPC_GENERIC, OP_CHAR_DOWNCASE, 1, 0, SEXP_CHAR, 0, 0, "char-downcase", 0, NULL), +_OP(OPC_ARITHMETIC, OP_ADD, 0, 1, SEXP_FIXNUM, 0, 0, "+", sexp_make_integer(0), NULL), +_OP(OPC_ARITHMETIC, OP_MUL, 0, 1, SEXP_FIXNUM, 0, 0, "*", sexp_make_integer(1), NULL), +_OP(OPC_ARITHMETIC_INV, OP_SUB, 0, 1, SEXP_FIXNUM, 0, OP_NEGATIVE, "-", 0, NULL), +_OP(OPC_ARITHMETIC_INV, OP_DIV, 0, 1, SEXP_FIXNUM, 0, OP_INVERSE, "/", 0, NULL), +_OP(OPC_ARITHMETIC, OP_QUOTIENT, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, 0, "quotient", 0, NULL), +_OP(OPC_ARITHMETIC, OP_REMAINDER, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, 0, "remainder", 0, NULL), +_OP(OPC_ARITHMETIC_CMP, OP_LT, 0, 1, SEXP_FIXNUM, 0, 0, "<", 0, NULL), +_OP(OPC_ARITHMETIC_CMP, OP_LE, 0, 1, SEXP_FIXNUM, 0, 0, "<=", 0, NULL), +_OP(OPC_ARITHMETIC_CMP, OP_LT, 0, 1, SEXP_FIXNUM, 0, 1, ">", 0, NULL), +_OP(OPC_ARITHMETIC_CMP, OP_LE, 0, 1, SEXP_FIXNUM, 0, 1, ">=", 0, NULL), +_OP(OPC_ARITHMETIC_CMP, OP_EQN, 0, 1, SEXP_FIXNUM, 0, 0, "=", 0, NULL), +_OP(OPC_PREDICATE, OP_EQ, 2, 0, 0, 0, 0, "eq?", 0, NULL), +_OP(OPC_CONSTRUCTOR, OP_CONS, 2, 0, 0, 0, 0, "cons", 0, NULL), +_OP(OPC_CONSTRUCTOR, OP_MAKE_VECTOR, 1, 1, SEXP_FIXNUM, 0, 0, "make-vector", SEXP_VOID, NULL), +_OP(OPC_CONSTRUCTOR, OP_MAKE_PROCEDURE, 4, 0, 0, 0, 0, "make-procedure", 0, NULL), +_OP(OPC_TYPE_PREDICATE, OP_NULLP, 1, 0, 0, 0, 0, "null?", 0, NULL), +_OP(OPC_TYPE_PREDICATE, OP_EOFP, 1, 0, 0, 0, 0, "eof-object?", 0, NULL), +_OP(OPC_TYPE_PREDICATE, OP_SYMBOLP, 1, 0, 0, 0, 0, "symbol?", 0, NULL), +_OP(OPC_TYPE_PREDICATE, OP_CHARP, 1, 0, 0, 0, 0, "char?", 0, NULL), +_OP(OPC_TYPE_PREDICATE, OP_INTEGERP, 1, 0, 0, 0, 0, "fixnum?", 0, NULL), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "pair?", 0, (sexp)SEXP_PAIR), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "string?", 0, (sexp)SEXP_STRING), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "vector?", 0, (sexp)SEXP_VECTOR), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "flonum?", 0, (sexp)SEXP_FLONUM), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "closure?", 0, (sexp)SEXP_PROCEDURE), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "opcode?", 0, (sexp)SEXP_OPCODE), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "input-port?", 0, (sexp)SEXP_IPORT), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "output-port?", 0, (sexp)SEXP_OPORT), +_OP(OPC_GENERIC, OP_APPLY1, 2, 0, SEXP_PROCEDURE, SEXP_PAIR, 0, "apply1", 0, NULL), +_OP(OPC_GENERIC, OP_CALLCC, 1, SEXP_PROCEDURE, 0, 0, 0, "call-with-current-continuation", 0, NULL), +_OP(OPC_GENERIC, OP_RAISE, 1, SEXP_STRING, 0, 0, 0, "raise", 0, NULL), +_OP(OPC_IO, OP_WRITE, 1, 3, 0, SEXP_OPORT, 0, "write", (sexp)"*current-output-port*", NULL), +_OP(OPC_IO, OP_DISPLAY, 1, 3, 0, SEXP_OPORT, 0, "display", (sexp)"*current-output-port*", NULL), +_OP(OPC_IO, OP_WRITE_CHAR, 1, 3, 0, SEXP_OPORT, 0, "write-char", (sexp)"*current-output-port*", NULL), +_OP(OPC_IO, OP_NEWLINE, 0, 3, 0, SEXP_OPORT, 0, "newline", (sexp)"*current-output-port*", NULL), +_OP(OPC_IO, OP_FLUSH_OUTPUT, 0, 3, 0, SEXP_OPORT, 0, "flush-output", (sexp)"*current-output-port*", NULL), +_OP(OPC_IO, OP_READ, 0, 3, 0, SEXP_IPORT, 0, "read", (sexp)"*current-input-port*", NULL), +_OP(OPC_IO, OP_READ_CHAR, 0, 3, 0, SEXP_IPORT, 0, "read-char", (sexp)"*current-input-port*", NULL), +_OP(OPC_IO, OP_PEEK_CHAR, 0, 3, 0, SEXP_IPORT, 0, "peek-char", (sexp)"*current-input-port*", NULL), +_OP(OPC_GENERIC, OP_EVAL, 1, 3, 0, 0, 0, "eval", (sexp)"*interaction-environment*", NULL), +_FN2(0, 0, "equal?", 0, sexp_equalp), +_FN1(0, "list?", 0, sexp_listp), +_FN1(0, "identifier?", 0, sexp_identifierp), +_FN1(0, "identifier->symbol", 0, sexp_syntactic_closure_expr), +_FN4(0, SEXP_ENV, "identifier=?", 0, sexp_identifier_eq), +_FN1(SEXP_PAIR, "length", 0, sexp_length), +_FN1(SEXP_PAIR, "reverse", 0, sexp_reverse), +_FN1(SEXP_PAIR, "reverse!", 0, sexp_nreverse), +_FN2(SEXP_PAIR, SEXP_PAIR, "append2", 0, sexp_append2), +_FN1(SEXP_PAIR, "list->vector", 0, sexp_list_to_vector), +_FN1(SEXP_STRING, "open-input-file", 0, sexp_open_input_file), +_FN1(SEXP_STRING, "open-output-file", 0, sexp_open_output_file), +_FN1(SEXP_IPORT, "close-input-port", 0, sexp_close_port), +_FN1(SEXP_OPORT, "close-output-port", 0, sexp_close_port), +_FN1(SEXP_FIXNUM, "null-environment", 0, sexp_make_null_env), +_FN1(SEXP_FIXNUM, "scheme-report-environment", 0, sexp_make_standard_env), +_FN2(SEXP_STRING, SEXP_ENV, "%load", 0, sexp_load), +_FN2(SEXP_EXCEPTION, SEXP_OPORT, "print-exception", 0, sexp_print_exception), +_FN1(SEXP_EXCEPTION, "exception-type", 0, sexp_exception_type_func), +_FN6(SEXP_SYMBOL, SEXP_STRING, "make-exception", 0, sexp_make_exception), +_FN2OPT(SEXP_FIXNUM, SEXP_CHAR, "make-string", sexp_make_character(' '), sexp_make_string), +_FN3(SEXP_STRING, SEXP_STRING, "string-cmp", 0, sexp_string_cmp), +_FN3(SEXP_STRING, SEXP_FIXNUM, "substring", 0, sexp_substring), +_FN1(SEXP_STRING, "string->symbol", 0, sexp_string_to_symbol), +_FN1(SEXP_PAIR, "string-concatenate", 0, sexp_string_concatenate), +_FN2(0, SEXP_PAIR, "memq", 0, sexp_memq), +_FN2(0, SEXP_PAIR, "assq", 0, sexp_assq), +_FN3(SEXP_ENV, SEXP_PAIR, "make-syntactic-closure", 0, sexp_make_synclo), +_PARAM("current-input-port", (sexp)"*current-input-port*", SEXP_IPORT), +_PARAM("current-output-port", (sexp)"*current-output-port*", SEXP_OPORT), +_PARAM("current-error-port", (sexp)"*current-error-port*", SEXP_OPORT), +_PARAM("current-exception-handler", (sexp)"*current-exception-handler*", SEXP_PROCEDURE), +_PARAM("interaction-environment", (sexp)"*interaction-environment*", SEXP_ENV), +#if USE_MATH +_FN1(0, "exp", 0, sexp_exp), +_FN1(0, "log", 0, sexp_log), +_FN1(0, "sin", 0, sexp_sin), +_FN1(0, "cos", 0, sexp_cos), +_FN1(0, "tan", 0, sexp_tan), +_FN1(0, "asin", 0, sexp_asin), +_FN1(0, "acos", 0, sexp_acos), +_FN1(0, "atan1", 0, sexp_atan), +_FN1(0, "sqrt", 0, sexp_sqrt), +_FN1(0, "round", 0, sexp_round), +_FN1(0, "truncate", 0, sexp_trunc), +_FN1(0, "floor", 0, sexp_floor), +_FN1(0, "ceiling", 0, sexp_ceiling), +_FN2(0, 0, "expt", 0, sexp_expt), +#endif +_FN0("open-output-string", 0, sexp_make_output_string_port), +_FN1(SEXP_STRING, "open-input-string", 0, sexp_make_input_string_port), +_FN1(SEXP_OPORT, "get-output-string", 0, sexp_get_output_string), +#if USE_DEBUG +_FN2(SEXP_PROCEDURE, SEXP_OPORT, "disasm", 0, sexp_disasm), +#endif +}; + diff --git a/opt/sexp-huff.c b/opt/sexp-huff.c new file mode 100644 index 00000000..abf6bc9f --- /dev/null +++ b/opt/sexp-huff.c @@ -0,0 +1,128 @@ + {12, 0x0C00}, /* '\x00' */ + {15, 0x0000}, /* '\x01' */ + {15, 0x4000}, /* '\x02' */ + {15, 0x2000}, /* '\x03' */ + {15, 0x6000}, /* '\x04' */ + {15, 0x0800}, /* '\x05' */ + {15, 0x4800}, /* '\x06' */ + {15, 0x2800}, /* '\x07' */ + {15, 0x6800}, /* '\x08' */ + {15, 0x1800}, /* '\x09' */ + {15, 0x5800}, /* '\x0a' */ + {15, 0x3800}, /* '\x0b' */ + {15, 0x7800}, /* '\x0c' */ + {15, 0x0100}, /* '\x0d' */ + {15, 0x4100}, /* '\x0e' */ + {15, 0x2100}, /* '\x0f' */ + {15, 0x6100}, /* '\x10' */ + {15, 0x1100}, /* '\x11' */ + {15, 0x5100}, /* '\x12' */ + {15, 0x3100}, /* '\x13' */ + {15, 0x7100}, /* '\x14' */ + {15, 0x0900}, /* '\x15' */ + {15, 0x4900}, /* '\x16' */ + {15, 0x2900}, /* '\x17' */ + {15, 0x6900}, /* '\x18' */ + {15, 0x1900}, /* '\x19' */ + {15, 0x5900}, /* '\x1a' */ + {15, 0x3900}, /* '\x1b' */ + {15, 0x7900}, /* '\x1c' */ + {15, 0x0500}, /* '\x1d' */ + {15, 0x4500}, /* '\x1e' */ + {15, 0x2500}, /* '\x1f' */ + {15, 0x6500}, /* '\x20' */ + { 8, 0x0040}, /* '!' */ + {15, 0x1500}, /* '"' */ + {15, 0x5500}, /* '#' */ + {15, 0x3500}, /* '$' */ + {15, 0x7500}, /* '%' */ + {15, 0x0D00}, /* '&' */ + {15, 0x4D00}, /* '\'' */ + {15, 0x2D00}, /* '(' */ + {15, 0x6D00}, /* ')' */ + {11, 0x0300}, /* '*' */ + {10, 0x0180}, /* '+' */ + {15, 0x1D00}, /* ',' */ + { 4, 0x000D}, /* '-' */ + {15, 0x5D00}, /* '.' */ + {10, 0x0380}, /* '/' */ + {15, 0x3D00}, /* '0' */ + {15, 0x7D00}, /* '1' */ + {14, 0x0080}, /* '2' */ + {14, 0x2080}, /* '3' */ + {14, 0x1080}, /* '4' */ + {14, 0x3080}, /* '5' */ + {14, 0x0880}, /* '6' */ + {14, 0x2880}, /* '7' */ + {14, 0x1880}, /* '8' */ + {14, 0x3880}, /* '9' */ + {14, 0x0480}, /* ':' */ + {14, 0x2480}, /* ';' */ + { 7, 0x0050}, /* '<' */ + { 7, 0x0042}, /* '=' */ + { 7, 0x0022}, /* '>' */ + { 5, 0x0009}, /* '?' */ + {14, 0x1480}, /* '@' */ + {14, 0x3480}, /* 'A' */ + {14, 0x0C80}, /* 'B' */ + {14, 0x2C80}, /* 'C' */ + {14, 0x1C80}, /* 'D' */ + {14, 0x3C80}, /* 'E' */ + {14, 0x0280}, /* 'F' */ + {14, 0x2280}, /* 'G' */ + {14, 0x1280}, /* 'H' */ + {14, 0x3280}, /* 'I' */ + {14, 0x0A80}, /* 'J' */ + {14, 0x2A80}, /* 'K' */ + {14, 0x1A80}, /* 'L' */ + {14, 0x3A80}, /* 'M' */ + {14, 0x0680}, /* 'N' */ + {14, 0x2680}, /* 'O' */ + {14, 0x1680}, /* 'P' */ + {14, 0x3680}, /* 'Q' */ + {14, 0x0E80}, /* 'R' */ + {14, 0x2E80}, /* 'S' */ + {14, 0x1E80}, /* 'T' */ + {14, 0x3E80}, /* 'U' */ + {14, 0x0200}, /* 'V' */ + {14, 0x2200}, /* 'W' */ + {14, 0x1200}, /* 'X' */ + {14, 0x3200}, /* 'Y' */ + {14, 0x0A00}, /* 'Z' */ + {14, 0x2A00}, /* '[' */ + {14, 0x1A00}, /* '\\' */ + {14, 0x3A00}, /* ']' */ + {14, 0x0600}, /* '^' */ + {14, 0x2600}, /* '_' */ + {14, 0x1600}, /* '`' */ + { 3, 0x0007}, /* 'a' */ + { 7, 0x0020}, /* 'b' */ + { 4, 0x0004}, /* 'c' */ + { 5, 0x001A}, /* 'd' */ + { 4, 0x0006}, /* 'e' */ + { 7, 0x0002}, /* 'f' */ + { 5, 0x0011}, /* 'g' */ + { 6, 0x0012}, /* 'h' */ + { 4, 0x000C}, /* 'i' */ + {12, 0x0400}, /* 'j' */ + { 8, 0x00C0}, /* 'k' */ + { 5, 0x0018}, /* 'l' */ + { 6, 0x0032}, /* 'm' */ + { 4, 0x0005}, /* 'n' */ + { 5, 0x000A}, /* 'o' */ + { 5, 0x0001}, /* 'p' */ + { 7, 0x0070}, /* 'q' */ + { 3, 0x0003}, /* 'r' */ + { 5, 0x0008}, /* 's' */ + { 4, 0x000E}, /* 't' */ + { 5, 0x0019}, /* 'u' */ + { 7, 0x0062}, /* 'v' */ + { 7, 0x0030}, /* 'w' */ + { 7, 0x0060}, /* 'x' */ + { 7, 0x0010}, /* 'y' */ + {11, 0x0700}, /* 'z' */ + {14, 0x3600}, /* '{' */ + {14, 0x0E00}, /* '|' */ + {14, 0x2E00}, /* '}' */ + {14, 0x1E00}, /* '~' */ + {14, 0x3E00}, /* '\x7f' */ diff --git a/opt/sexp-hufftabs.c b/opt/sexp-hufftabs.c new file mode 100644 index 00000000..7704184f --- /dev/null +++ b/opt/sexp-hufftabs.c @@ -0,0 +1,92 @@ +/* auto-generated by ./symhuff.scm on Sun Feb 25 23:12:52 2007 */ + +char _huff_tab21[] = { + '\x01', '\x00', '\x03', '\x00', '\x02', '\x00', '\x04', '\x00', +}; + +char _huff_tab19[] = { + '\x01', 'j', '\x01', '\x00', +}; + +char _huff_tab20[] = { + '\x05', '\x09', '\x07', '\x0b', '\x06', '\x0a', '\x08', '\x0c', +}; + +char _huff_tab18[] = { + '2', ':', '6', 'B', '4', '@', '8', 'D', + '3', ';', '7', 'C', '5', 'A', '9', 'E', +}; + +char _huff_tab17[] = { + '\x0d', '\x1d', '\x15', '&', '\x11', '"', '\x19', ',', + '\x0f', '\x1f', '\x17', '(', '\x13', '$', '\x1b', '0', + '\x0e', '\x1e', '\x16', '\'', '\x12', '#', '\x1a', '.', + '\x10', '\x20', '\x18', ')', '\x14', '%', '\x1c', '1', +}; + +char _huff_tab16[] = { + 'V', '^', 'Z', '|', 'X', '`', '\\', '~', + 'W', '_', '[', '}', 'Y', '{', ']', '\x7f', +}; + +char _huff_tab15[] = { + 'F', 'N', 'J', 'R', 'H', 'P', 'L', 'T', + 'G', 'O', 'K', 'S', 'I', 'Q', 'M', 'U', +}; + +char _huff_tab13[] = { + '\x00', '\x00', '\x00', '+', '\x00', '\x00', '\x00', '/', +}; + +char _huff_tab14[] = { + '*', 'z', +}; + +char _huff_tab11[] = { + '\x00', 'b', '\x00', 'x', +}; + +char _huff_tab12[] = { + '!', 'k', +}; + +char _huff_tab9[] = { + '\x00', 's', '\x00', 'l', +}; + +char _huff_tab10[] = { + 'y', 'w', '<', 'q', +}; + +char _huff_tab8[] = { + 'p', '?', 'g', 'u', +}; + +char _huff_tab7[] = { + 'f', '>', '=', 'v', +}; + +char _huff_tab5[] = { + '\x00', 'o', '\x00', 'd', +}; + +char _huff_tab6[] = { + 'h', 'm', +}; + +char _huff_tab4[] = { + 'c', 'i', +}; + +char _huff_tab3[] = { + 'n', '-', +}; + +char _huff_tab1[] = { + '\x00', '\x00', '\x00', 'r', '\x00', '\x00', '\x00', 'a', +}; + +char _huff_tab2[] = { + 'e', 't', +}; + diff --git a/opt/sexp-unhuff.c b/opt/sexp-unhuff.c new file mode 100644 index 00000000..fa142e16 --- /dev/null +++ b/opt/sexp-unhuff.c @@ -0,0 +1,71 @@ +/* auto-generated by ./symhuff.scm on Sun Feb 25 23:12:52 2007 */ + +res = c & 7; +c = c >> 3; +if (res == 0) { + res = c & 3; + c = c >> 2; + if (res == 0) { + res = c & 3; + c = c >> 2; + if (res == 0) { + res = c & 7; + c = c >> 3; + if (res == 0) { + res = c & 3; + c = c >> 2; + if (res == 0) { + res = _huff_tab21[c & 7]; + c = c >> 3; + } else if ((res = _huff_tab19[res]) == '\x01') { + res = _huff_tab20[c & 7]; + c = c >> 3; + } + } else if (res == 1) { + res = _huff_tab18[c & 15]; + c = c >> 4; + } else if (res == 2) { + res = _huff_tab17[c & 31]; + c = c >> 5; + } else if (res == 4) { + res = _huff_tab16[c & 15]; + c = c >> 4; + } else if (res == 5) { + res = _huff_tab15[c & 15]; + c = c >> 4; + } else if ((res = _huff_tab13[res]) == '\x00') { + res = _huff_tab14[c & 1]; + c = c >> 1; + } + } else if ((res = _huff_tab11[res]) == '\x00') { + res = _huff_tab12[c & 1]; + c = c >> 1; + } + } else if ((res = _huff_tab9[res]) == '\x00') { + res = _huff_tab10[c & 3]; + c = c >> 2; + } + } else if (res == 1) { + res = _huff_tab8[c & 3]; + c = c >> 2; + } else if (res == 2) { + res = c & 3; + c = c >> 2; + if (res == 0) { + res = _huff_tab7[c & 3]; + c = c >> 2; + } else if ((res = _huff_tab5[res]) == '\x00') { + res = _huff_tab6[c & 1]; + c = c >> 1; + } + } else if (res == 4) { + res = _huff_tab4[c & 1]; + c = c >> 1; + } else if (res == 5) { + res = _huff_tab3[c & 1]; + c = c >> 1; + } else if ((res = _huff_tab1[res]) == '\x00') { + res = _huff_tab2[c & 1]; + c = c >> 1; + } + diff --git a/sexp.c b/sexp.c new file mode 100644 index 00000000..78ed8f48 --- /dev/null +++ b/sexp.c @@ -0,0 +1,1357 @@ +/* sexp.c -- standalone sexp library implementation */ +/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ + +#define SEXP_API +#include "chibi/sexp.h" + +/* optional huffman-compressed immediate symbols */ +struct sexp_huff_entry { + unsigned char len; + unsigned short bits; +}; + +#if USE_HUFF_SYMS +#include "opt/sexp-hufftabs.c" +static struct sexp_huff_entry huff_table[] = { +#include "opt/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_ */ +}; + +static int digit_value (c) { + return (((c)<='9') ? ((c) - '0') : ((toupper(c) - 'A') + 10)); +} + +static int hex_digit (n) { + return ((n<=9) ? ('0' + n) : ('A' + n - 10)); +} + +static int is_separator(int c) { + return 0= sexp_make_integer(0))) { + sexp_write_string(ctx, " on line ", out); + sexp_write(ctx, sexp_cdr(sexp_exception_source(exn)), out); + } + if (sexp_stringp(sexp_car(sexp_exception_source(exn)))) { + sexp_write_string(ctx, " of file ", out); + sexp_write_string(ctx, sexp_string_data(sexp_car(sexp_exception_source(exn))), out); + } + } + sexp_write_string(ctx, ": ", out); + sexp_write_string(ctx, sexp_string_data(sexp_exception_message(exn)), out); + if (sexp_exception_irritants(exn) + && sexp_pairp(sexp_exception_irritants(exn))) { + if (sexp_nullp(sexp_cdr(sexp_exception_irritants(exn)))) { + sexp_write_string(ctx, ": ", out); + sexp_write(ctx, sexp_car(sexp_exception_irritants(exn)), out); + sexp_write_string(ctx, "\n", out); + } else { + sexp_write_string(ctx, "\n", out); + for (ls=sexp_exception_irritants(exn); + sexp_pairp(ls); ls=sexp_cdr(ls)) { + sexp_write_string(ctx, " ", out); + sexp_write(ctx, sexp_car(ls), out); + sexp_write_char(ctx, '\n', out); + } + } + } else { + sexp_write_char(ctx, '\n', out); + } + } else { + sexp_write_string(ctx, ": ", out); + if (sexp_stringp(exn)) + sexp_write_string(ctx, sexp_string_data(exn), out); + else + sexp_write(ctx, exn, out); + sexp_write_char(ctx, '\n', out); + } + return SEXP_VOID; +} + +static sexp sexp_read_error (sexp ctx, char *msg, sexp irritants, sexp port) { + sexp res; + sexp_gc_var(ctx, name, s_name); + sexp_gc_var(ctx, str, s_str); + sexp_gc_var(ctx, irr, s_irr); + sexp_gc_var(ctx, src, s_src); + sexp_gc_preserve(ctx, name, s_name); + sexp_gc_preserve(ctx, str, s_str); + sexp_gc_preserve(ctx, irr, s_irr); + sexp_gc_preserve(ctx, src, s_src); + name = (sexp_port_name(port) ? sexp_port_name(port) : SEXP_FALSE); + name = sexp_cons(ctx, name, sexp_make_integer(sexp_port_line(port))); + str = sexp_c_string(ctx, msg, -1); + irr = ((sexp_pairp(irritants) || sexp_nullp(irritants)) + ? irritants : sexp_list1(ctx, irritants)); + res = sexp_make_exception(ctx, the_read_error_symbol, + str, irr, SEXP_FALSE, name); + sexp_gc_release(ctx, name, s_name); + return res; +} + +/*************************** list utilities ***************************/ + +sexp sexp_cons (sexp ctx, sexp head, sexp tail) { + sexp pair = sexp_alloc_type(ctx, pair, SEXP_PAIR); + sexp_car(pair) = head; + sexp_cdr(pair) = tail; + sexp_pair_source(pair) = SEXP_FALSE; + return pair; +} + +sexp sexp_list2 (sexp ctx, sexp a, sexp b) { + sexp_gc_var(ctx, res, s_res); + sexp_gc_preserve(ctx, res, s_res); + res = sexp_cons(ctx, b, SEXP_NULL); + res = sexp_cons(ctx, a, res); + sexp_gc_release(ctx, res, s_res); + return res; +} + +sexp sexp_listp (sexp ctx, sexp hare) { + sexp turtle; + if (! sexp_pairp(hare)) + return sexp_make_boolean(sexp_nullp(hare)); + turtle = hare; + hare = sexp_cdr(hare); + for ( ; sexp_pairp(hare); turtle=sexp_cdr(turtle)) { + if (hare == turtle) return SEXP_FALSE; + hare = sexp_cdr(hare); + if (sexp_pairp(hare)) hare = sexp_cdr(hare); + } + return sexp_make_boolean(sexp_nullp(hare)); +} + +sexp sexp_memq (sexp ctx, 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 ctx, sexp x, sexp ls) { + while (sexp_pairp(ls)) + if (sexp_pairp(sexp_car(ls)) && (x == sexp_caar(ls))) + return sexp_car(ls); + else + ls = sexp_cdr(ls); + return SEXP_FALSE; +} + +sexp sexp_reverse (sexp ctx, sexp ls) { + sexp_gc_var(ctx, res, s_res); + sexp_gc_preserve(ctx, res, s_res); + for (res=SEXP_NULL; sexp_pairp(ls); ls=sexp_cdr(ls)) + res = sexp_cons(ctx, sexp_car(ls), res); + sexp_gc_release(ctx, res, s_res); + return res; +} + +sexp sexp_nreverse (sexp ctx, sexp ls) { + sexp a, b, tmp; + if (ls == SEXP_NULL) { + return ls; + } else if (! sexp_pairp(ls)) { + return SEXP_NULL; /* XXXX return an exception */ + } 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_append2 (sexp ctx, sexp a, sexp b) { + sexp_gc_var(ctx, a1, s_a1); + sexp_gc_var(ctx, b1, s_b1); + sexp_gc_preserve(ctx, a1, s_a1); + sexp_gc_preserve(ctx, b1, s_b1); + b1 = b; + for (a1=sexp_reverse(ctx, a); sexp_pairp(a1); a1=sexp_cdr(a1)) + b1 = sexp_cons(ctx, sexp_car(a1), b1); + sexp_gc_release(ctx, a1, s_a1); + return b1; +} + +sexp sexp_length (sexp ctx, sexp ls) { + sexp_uint_t res=0; + for ( ; sexp_pairp(ls); res++, ls=sexp_cdr(ls)) + ; + return sexp_make_integer(res); +} + +sexp sexp_equalp (sexp ctx, sexp a, sexp b) { + sexp_uint_t len; + sexp *v1, *v2; + loop: + if (a == b) + return SEXP_TRUE; +#if USE_IMMEDIATE_FLONUMS + if ((! sexp_pointerp(a)) || (! sexp_pointerp(b))) + return + sexp_make_boolean((a == b) + || (sexp_flonump(a) + && sexp_make_integer(sexp_flonum_value(a)) == b) + || (sexp_flonump(b) + && sexp_make_integer(sexp_flonum_value(b)) == a)); +#else + if (! sexp_pointerp(a)) + return sexp_make_boolean(sexp_integerp(a) && sexp_pointerp(b) + && (sexp_unbox_integer(a) + == sexp_flonum_value(b))); + else if (! sexp_pointerp(b)) + return sexp_make_boolean(sexp_integerp(b) && sexp_pointerp(a) + && (sexp_unbox_integer(b) + == sexp_flonum_value(a))); +#endif + if (sexp_pointer_tag(a) != sexp_pointer_tag(b)) + return SEXP_FALSE; + switch (sexp_pointer_tag(a)) { + case SEXP_PAIR: + if (sexp_equalp(ctx, sexp_car(a), sexp_car(b)) == SEXP_FALSE) + return SEXP_FALSE; + a = sexp_cdr(a); + b = sexp_cdr(b); + goto loop; + case SEXP_VECTOR: + len = sexp_vector_length(a); + if (len != sexp_vector_length(b)) + return SEXP_FALSE; + v1 = sexp_vector_data(a); + v2 = sexp_vector_data(b); + for (len--; len > 0; len--) + if (sexp_equalp(ctx, v1[len], v2[len]) == SEXP_FALSE) + return SEXP_FALSE; + return SEXP_TRUE; + case SEXP_STRING: + return sexp_make_boolean((sexp_string_length(a) == sexp_string_length(b)) + && (! strncmp(sexp_string_data(a), + sexp_string_data(b), + sexp_string_length(a)))); +#if ! USE_IMMEDIATE_FLONUMS + case SEXP_FLONUM: + return sexp_make_boolean(sexp_flonum_value(a) == sexp_flonum_value(b)); +#endif + default: + return SEXP_FALSE; + } +} + +/********************* strings, symbols, vectors **********************/ + +#if ! USE_IMMEDIATE_FLONUMS +sexp sexp_make_flonum(sexp ctx, double f) { + sexp x = sexp_alloc_type(ctx, flonum, SEXP_FLONUM); + sexp_flonum_value(x) = f; + return x; +} +#endif + +sexp sexp_make_string(sexp ctx, sexp len, sexp ch) { + sexp_sint_t clen = sexp_unbox_integer(len); + sexp s; + if (clen < 0) return sexp_type_exception(ctx, "negative length", len); + s = sexp_alloc_atomic(ctx, sexp_sizeof(string)+clen+1); + sexp_pointer_tag(s) = SEXP_STRING; + sexp_string_length(s) = clen; + if (sexp_charp(ch)) + memset(sexp_string_data(s), sexp_unbox_character(ch), clen); + sexp_string_data(s)[clen] = '\0'; + return s; +} + +sexp sexp_c_string(sexp ctx, char *str, sexp_sint_t slen) { + sexp_sint_t len = ((slen >= 0) ? slen : strlen(str)); + sexp s = sexp_make_string(ctx, sexp_make_integer(len), SEXP_VOID); + memcpy(sexp_string_data(s), str, len); + sexp_string_data(s)[len] = '\0'; + return s; +} + +sexp sexp_substring (sexp ctx, sexp str, sexp start, sexp end) { + sexp res; + if (! sexp_stringp(str)) + return sexp_type_exception(ctx, "not a string", str); + if (! sexp_integerp(start)) + return sexp_type_exception(ctx, "not a number", start); + if (sexp_not(end)) + end = sexp_make_integer(sexp_string_length(str)); + if (! sexp_integerp(end)) + return sexp_type_exception(ctx, "not a number", end); + if ((sexp_unbox_integer(start) < 0) + || (sexp_unbox_integer(start) > sexp_string_length(str)) + || (sexp_unbox_integer(end) < 0) + || (sexp_unbox_integer(end) > sexp_string_length(str)) + || (end < start)) + return sexp_range_exception(ctx, str, start, end); + res = sexp_make_string(ctx, sexp_fx_sub(end, start), SEXP_VOID); + memcpy(sexp_string_data(res), + sexp_string_data(str)+sexp_unbox_integer(start), + sexp_string_length(res)); + sexp_string_data(res)[sexp_string_length(res)] = '\0'; + return res; +} + +sexp sexp_string_concatenate (sexp ctx, sexp str_ls) { + sexp res, ls; + sexp_uint_t len=0; + char *p; + for (ls=str_ls; sexp_pairp(ls); ls=sexp_cdr(ls)) + if (! sexp_stringp(sexp_car(ls))) + return sexp_type_exception(ctx, "not a string", sexp_car(ls)); + else + len += sexp_string_length(sexp_car(ls)); + res = sexp_make_string(ctx, sexp_make_integer(len), SEXP_VOID); + p = sexp_string_data(res); + for (ls=str_ls; sexp_pairp(ls); ls=sexp_cdr(ls)) { + len = sexp_string_length(sexp_car(ls)); + memcpy(p, sexp_string_data(sexp_car(ls)), len); + p += len; + } + *p = '\0'; + return res; +} + +#define FNV_PRIME 16777619 +#define FNV_OFFSET_BASIS 2166136261uL + +#if USE_HASH_SYMS + +static sexp_uint_t sexp_string_hash(char *str, sexp_uint_t acc) { + while (*str) {acc *= FNV_PRIME; acc ^= *str++;} + return acc; +} + +#endif + +sexp sexp_intern(sexp ctx, char *str) { + struct sexp_huff_entry he; + sexp_uint_t len, res=FNV_OFFSET_BASIS, space=3, newbits, bucket; + char c, *p=str; + sexp ls; + sexp_gc_var(ctx, sym, s_sym); + +#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: +#if USE_HASH_SYMS + bucket = (sexp_string_hash(p, res) % SEXP_SYMBOL_TABLE_SIZE); +#else + bucket = 0; +#endif + len = strlen(str); + for (ls=sexp_symbol_table[bucket]; sexp_pairp(ls); ls=sexp_cdr(ls)) + if (! strncmp(str, sexp_string_data(sexp_symbol_string(sexp_car(ls))), len)) + return sexp_car(ls); + + /* not found, make a new symbol */ + sexp_gc_preserve(ctx, sym, s_sym); + sym = sexp_alloc_type(ctx, symbol, SEXP_SYMBOL); + sexp_symbol_string(sym) = sexp_c_string(ctx, str, len); + sexp_push(ctx, sexp_symbol_table[bucket], sym); + sexp_gc_release(ctx, sym, s_sym); + return sym; +} + +sexp sexp_string_to_symbol (sexp ctx, sexp str) { + return sexp_intern(ctx, sexp_string_data(str)); +} + +sexp sexp_make_vector(sexp ctx, sexp len, sexp dflt) { + sexp v, *x; + int i, clen = sexp_unbox_integer(len); + if (! clen) return the_empty_vector; + v = sexp_alloc_tagged(ctx, sexp_sizeof(vector) + clen*sizeof(sexp), + SEXP_VECTOR); + x = sexp_vector_data(v); + for (i=0; i= len) return 0; + if (n > (len - pos)) n = (len - pos); + memcpy(dst, sexp_string_data(sexp_stream_buf(vec))+pos, n); + sexp_stream_pos(vec) = sexp_make_integer(n); + return n; +} + +int sstream_write (void *vec, const char *src, int n) { + sexp_uint_t len, pos, newpos; + sexp newbuf; + len = sexp_unbox_integer(sexp_stream_size(vec)); + pos = sexp_unbox_integer(sexp_stream_pos(vec)); + newpos = pos+n; + if (newpos >= len) { + newbuf = sexp_make_string(sexp_stream_ctx(vec), + sexp_make_integer(newpos*2), + SEXP_VOID); + memcpy(sexp_string_data(newbuf), + sexp_string_data(sexp_stream_buf(vec)), + pos); + sexp_stream_buf(vec) = newbuf; + sexp_stream_size(vec) = sexp_make_integer(newpos*2); + } + memcpy(sexp_string_data(sexp_stream_buf(vec))+pos, src, n); + sexp_stream_pos(vec) = sexp_make_integer(newpos); + return n; +} + +off_t sstream_seek (void *vec, off_t offset, int whence) { + sexp_sint_t pos; + if (whence == SEEK_SET) { + pos = offset; + } else if (whence == SEEK_CUR) { + pos = sexp_unbox_integer(sexp_stream_pos(vec)) + offset; + } else { /* SEEK_END */ + pos = sexp_unbox_integer(sexp_stream_size(vec)) + offset; + } + sexp_stream_pos(vec) = sexp_make_integer(pos); + return pos; +} + +sexp sexp_make_input_string_port (sexp ctx, sexp str) { + FILE *in; + sexp res; + sexp_gc_var(ctx, cookie, s_cookie); + sexp_gc_preserve(ctx, cookie, s_cookie); + cookie = sexp_make_vector(ctx, sexp_make_integer(4), SEXP_VOID); + sexp_stream_ctx(cookie) = ctx; + sexp_stream_buf(cookie) = str; + sexp_stream_size(cookie) = sexp_make_integer(sexp_string_length(str)); + sexp_stream_pos(cookie) = sexp_make_integer(0); + in = funopen(cookie, &sstream_read, NULL, &sstream_seek, NULL); + res = sexp_make_input_port(ctx, in, SEXP_FALSE); + sexp_port_cookie(res) = cookie; + sexp_gc_release(ctx, cookie, s_cookie); + return res; +} + +sexp sexp_make_output_string_port (sexp ctx) { + FILE *out; + sexp res, size; + sexp_gc_var(ctx, cookie, s_cookie); + sexp_gc_preserve(ctx, cookie, s_cookie); + size = sexp_make_integer(SEXP_INIT_STRING_PORT_SIZE); + cookie = sexp_make_vector(ctx, sexp_make_integer(4), SEXP_VOID); + sexp_stream_ctx(cookie) = ctx; + sexp_stream_buf(cookie) = sexp_make_string(ctx, size, SEXP_VOID); + sexp_stream_size(cookie) = size; + sexp_stream_pos(cookie) = sexp_make_integer(0); + out = funopen(cookie, NULL, &sstream_write, &sstream_seek, NULL); + res = sexp_make_output_port(ctx, out, SEXP_FALSE); + sexp_port_cookie(res) = cookie; + sexp_gc_release(ctx, cookie, s_cookie); + return res; +} + +sexp sexp_get_output_string (sexp ctx, sexp port) { + sexp cookie = sexp_port_cookie(port); + fflush(sexp_port_stream(port)); + return sexp_substring(ctx, + sexp_stream_buf(cookie), + sexp_make_integer(0), + sexp_stream_pos(cookie)); +} + +#else + +sexp sexp_make_input_string_port (sexp ctx, sexp str) { + FILE *in = fmemopen(sexp_string_data(str), sexp_string_length(str), "r"); + sexp res = sexp_make_input_port(ctx, in, SEXP_FALSE); + sexp_port_cookie(res) = str; /* for gc preservation */ + return res; +} + +sexp sexp_make_output_string_port (sexp ctx) { + sexp res = sexp_make_output_port(ctx, NULL, SEXP_FALSE); + sexp_port_stream(res) + = open_memstream(&sexp_port_buf(res), &sexp_port_size(res)); + return res; +} + +sexp sexp_get_output_string (sexp ctx, sexp port) { + fflush(sexp_port_stream(port)); + return sexp_c_string(ctx, sexp_port_buf(port), sexp_port_size(port)); +} + +#endif + +#else + +#define SEXP_PORT_BUFFER_SIZE 4096 + +int sexp_buffered_read_char (sexp ctx, sexp p) { + if (sexp_port_offset(p) < sexp_port_size(p)) { + return sexp_port_buf(p)[sexp_port_offset(p)++]; + } else if (! sexp_port_stream(p)) { + return EOF; + } else { + sexp_port_size(p) + = fread(sexp_port_buf(p), 1, SEXP_PORT_BUFFER_SIZE, sexp_port_stream(p)); + sexp_port_offset(p) = 0; + return ((sexp_port_offset(p) < sexp_port_size(p)) + ? sexp_port_buf(p)[sexp_port_offset(p)++] : EOF); + } +} + +sexp sexp_buffered_write_char (sexp ctx, int c, sexp p) { + if (sexp_port_offset(p) >= sexp_port_size(p)) + sexp_buffered_flush(ctx, p); + sexp_port_buf(p)[sexp_port_offset(p)++] = c; + return SEXP_VOID; +} + +sexp sexp_buffered_write_string_n (sexp ctx, char *str, sexp_uint_t len, sexp p) { + if (sexp_port_offset(p) >= sexp_port_size(p)) + sexp_buffered_flush(ctx, p); + memcpy(sexp_port_buf(p)+sexp_port_offset(p), str, len); + sexp_port_offset(p) += len; + return SEXP_VOID; +} + +sexp sexp_buffered_write_string (sexp ctx, char *str, sexp p) { + return sexp_buffered_write_string_n(ctx, str, strlen(str), p); +} + +sexp sexp_buffered_flush (sexp ctx, sexp p) { + sexp_gc_var(ctx, tmp, s_tmp); + if (! sexp_oportp(p)) + return sexp_type_exception(ctx, "not an output-port", p); + else if (! sexp_port_openp(p)) + return sexp_user_exception(ctx, SEXP_FALSE, "port is closed", p); + else { + if (sexp_port_stream(p)) { + fwrite(sexp_port_buf(p), 1, sexp_port_offset(p), sexp_port_stream(p)); + fflush(sexp_port_stream(p)); + } else if (sexp_port_offset(p) > 0) { + sexp_gc_preserve(ctx, tmp, s_tmp); + tmp = sexp_c_string(ctx, sexp_port_buf(p), sexp_port_offset(p)); + sexp_push(ctx, sexp_port_cookie(p), tmp); + sexp_gc_release(ctx, tmp, s_tmp); + } + sexp_port_offset(p) = 0; + return SEXP_VOID; + } +} + +sexp sexp_make_input_string_port (sexp ctx, sexp str) { + sexp res = sexp_make_input_port(ctx, NULL, SEXP_FALSE); + sexp_port_cookie(res) = str; + sexp_port_buf(res) = sexp_string_data(str); + sexp_port_offset(res) = 0; + sexp_port_size(res) = sexp_string_length(str); + return res; +} + +sexp sexp_make_output_string_port (sexp ctx) { + sexp res = sexp_make_output_port(ctx, NULL, SEXP_FALSE); + sexp_port_buf(res) = (char*) malloc(SEXP_PORT_BUFFER_SIZE); + sexp_port_size(res) = SEXP_PORT_BUFFER_SIZE; + sexp_port_offset(res) = 0; + sexp_port_cookie(res) = SEXP_NULL; + return res; +} + +sexp sexp_get_output_string (sexp ctx, sexp out) { + sexp res; + sexp_gc_var(ctx, ls, s_ls); + sexp_gc_var(ctx, tmp, s_tmp); + sexp_gc_preserve(ctx, ls, s_ls); + sexp_gc_preserve(ctx, tmp, s_tmp); + if (sexp_port_offset(out) > 0) { + tmp = sexp_c_string(ctx, sexp_port_buf(out), sexp_port_offset(out)); + ls = sexp_cons(ctx, tmp, sexp_port_cookie(out)); + } else { + ls = sexp_port_cookie(out); + } + res = sexp_string_concatenate(ctx, ls); + sexp_gc_release(ctx, ls, s_ls); + return res; +} + +#endif + +sexp sexp_make_input_port (sexp ctx, FILE* in, sexp name) { + sexp p = sexp_alloc_type(ctx, port, SEXP_IPORT); + sexp_port_stream(p) = in; + sexp_port_name(p) = name; + sexp_port_line(p) = 1; + sexp_port_buf(p) = NULL; + sexp_port_openp(p) = 1; + sexp_port_sourcep(p) = 1; + sexp_port_cookie(p) = SEXP_VOID; + return p; +} + +sexp sexp_make_output_port (sexp ctx, FILE* out, sexp name) { + sexp p = sexp_make_input_port(ctx, out, name); + sexp_pointer_tag(p) = SEXP_OPORT; + return p; +} + +void sexp_write (sexp ctx, sexp obj, sexp out) { + unsigned long len, c, res; + long i=0; + double f; + sexp x, *elts; + char *str=NULL, numbuf[20]; + + if (! obj) { + sexp_write_string(ctx, "#", out); /* shouldn't happen */ + } else if (sexp_pointerp(obj)) { + switch (sexp_pointer_tag(obj)) { + case SEXP_PAIR: + sexp_write_char(ctx, '(', out); + sexp_write(ctx, sexp_car(obj), out); + for (x=sexp_cdr(obj); sexp_pairp(x); x=sexp_cdr(x)) { + sexp_write_char(ctx, ' ', out); + sexp_write(ctx, sexp_car(x), out); + } + if (! sexp_nullp(x)) { + sexp_write_string(ctx, " . ", out); + sexp_write(ctx, x, out); + } + sexp_write_char(ctx, ')', out); + break; + case SEXP_VECTOR: + len = sexp_vector_length(obj); + elts = sexp_vector_data(obj); + if (len == 0) { + sexp_write_string(ctx, "#()", out); + } else { + sexp_write_string(ctx, "#(", out); + sexp_write(ctx, elts[0], out); + for (i=1; i", out); + break; + case SEXP_STRING: + sexp_write_char(ctx, '"', out); + i = sexp_string_length(obj); + str = sexp_string_data(obj); + for ( ; i>0; str++, i--) { + switch (str[0]) { + case '\\': sexp_write_string(ctx, "\\\\", out); break; + case '"': sexp_write_string(ctx, "\\\"", out); break; + case '\n': sexp_write_string(ctx, "\\n", out); break; + case '\r': sexp_write_string(ctx, "\\r", out); break; + case '\t': sexp_write_string(ctx, "\\t", out); break; + default: sexp_write_char(ctx, str[0], out); + } + } + sexp_write_char(ctx, '"', out); + break; + case SEXP_SYMBOL: + i = sexp_string_length(sexp_symbol_string(obj)); + str = sexp_string_data(sexp_symbol_string(obj)); + for ( ; i>0; str++, i--) { + if ((str[0] == '\\') || is_separator(str[0])) + sexp_write_char(ctx, '\\', out); + sexp_write_char(ctx, str[0], out); + } + break; + default: + i = sexp_pointer_tag(obj); + sexp_write_string(ctx, "#<", out); + sexp_write_string(ctx, + (i < SEXP_NUM_TYPES) + ? sexp_type_name(&(sexp_type_specs[i])) : "invalid", + out); + sexp_write_char(ctx, '>', out); + break; + } + } else if (sexp_integerp(obj)) { + sprintf(numbuf, "%ld", sexp_unbox_integer(obj)); + sexp_write_string(ctx, numbuf, out); +#if USE_IMMEDIATE_FLONUMS + } else if (sexp_flonump(obj)) { + f = sexp_flonum_value(obj); + i = sprintf(numbuf, "%.15g", f); + if (f == trunc(f)) { + numbuf[i++] = '.'; numbuf[i++] = '0'; numbuf[i++] = '\0'; + } + sexp_write_string(ctx, numbuf, out); +#endif + } else if (sexp_charp(obj)) { + if (obj == sexp_make_character(' ')) + sexp_write_string(ctx, "#\\space", out); + else if (obj == sexp_make_character('\n')) + sexp_write_string(ctx, "#\\newline", out); + else if (obj == sexp_make_character('\r')) + sexp_write_string(ctx, "#\\return", out); + else if (obj == sexp_make_character('\t')) + sexp_write_string(ctx, "#\\tab", out); + else if ((33 <= sexp_unbox_character(obj)) + && (sexp_unbox_character(obj) < 127)) { + sexp_write_string(ctx, "#\\", out); + sexp_write_char(ctx, sexp_unbox_character(obj), out); + } else { + sexp_write_string(ctx, "#\\x", out); + sexp_write_char(ctx, hex_digit(sexp_unbox_character(obj)>>4), out); + sexp_write_char(ctx, hex_digit(sexp_unbox_character(obj)&0xF), out); + } + } 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 "opt/sexp-unhuff.c" + sexp_write_char(ctx, res, out); + } + } +#endif + + } else { + switch ((sexp_uint_t) obj) { + case (sexp_uint_t) SEXP_NULL: + sexp_write_string(ctx, "()", out); break; + case (sexp_uint_t) SEXP_TRUE: + sexp_write_string(ctx, "#t", out); break; + case (sexp_uint_t) SEXP_FALSE: + sexp_write_string(ctx, "#f", out); break; + case (sexp_uint_t) SEXP_EOF: + sexp_write_string(ctx, "#", out); break; + case (sexp_uint_t) SEXP_UNDEF: + case (sexp_uint_t) SEXP_VOID: + sexp_write_string(ctx, "#", out); break; + default: + sexp_write_string(ctx, "#", out); + } + } +} + +#define INIT_STRING_BUFFER_SIZE 128 + +sexp sexp_read_string(sexp ctx, sexp in) { + int c, i=0, size=INIT_STRING_BUFFER_SIZE; + char initbuf[INIT_STRING_BUFFER_SIZE]; + char *buf=initbuf, *tmp; + sexp res; + + for (c = sexp_read_char(ctx, in); c != '"'; c = sexp_read_char(ctx, in)) { + if (c == '\\') { + c = sexp_read_char(ctx, in); + switch (c) {case 'n': c = '\n'; break; case 't': c = '\t'; break;} + } + if (c == EOF) { + res = sexp_read_error(ctx, "premature end of string", SEXP_NULL, in); + break; + } + buf[i++] = c; + if (i >= size) { /* expand buffer w/ malloc(), later free() it */ + tmp = (char*) malloc(size*2); + memcpy(tmp, buf, i); + if (size != INIT_STRING_BUFFER_SIZE) free(buf); + buf = tmp; + size *= 2; + } + } + + buf[i] = '\0'; + res = sexp_c_string(ctx, buf, i); + if (size != INIT_STRING_BUFFER_SIZE) free(buf); + return res; +} + +sexp sexp_read_symbol(sexp ctx, sexp in, int init, int internp) { + int c, i=0, size=INIT_STRING_BUFFER_SIZE; + char initbuf[INIT_STRING_BUFFER_SIZE]; + char *buf=initbuf, *tmp; + sexp res; + + if (init != EOF) + buf[i++] = init; + + for (c = sexp_read_char(ctx, in); c != '"'; c = sexp_read_char(ctx, in)) { + if (c == '\\') c = sexp_read_char(ctx, in); + if (c == EOF || is_separator(c)) { + sexp_push_char(ctx, c, in); + break; + } + buf[i++] = c; + if (i >= size) { /* expand buffer w/ malloc(), later free() it */ + tmp = (char*) malloc(size*2); + memcpy(tmp, buf, i); + if (size != INIT_STRING_BUFFER_SIZE) free(buf); + buf = tmp; + size *= 2; + } + } + + buf[i] = '\0'; + res = (internp ? sexp_intern(ctx, buf) : sexp_c_string(ctx, buf, i)); + if (size != INIT_STRING_BUFFER_SIZE) free(buf); + return res; +} + +sexp sexp_read_float_tail(sexp ctx, sexp in, sexp_sint_t whole) { + sexp exponent; + double res=0.0, scale=0.1, e=0.0; + int c; + for (c=sexp_read_char(ctx, in); + isdigit(c); + c=sexp_read_char(ctx, in), scale*=0.1) + res += digit_value(c)*scale; + sexp_push_char(ctx, c, in); + if (c=='e' || c=='E') { + exponent = sexp_read_number(ctx, in, 10); + if (sexp_exceptionp(exponent)) return exponent; + e = (sexp_integerp(exponent) ? sexp_unbox_integer(exponent) + : sexp_flonump(exponent) ? sexp_flonum_value(exponent) : 0.0); + } else if ((c!=EOF) && ! is_separator(c)) + return sexp_read_error(ctx, "invalid numeric syntax", + sexp_make_character(c), in); + return sexp_make_flonum(ctx, (whole + res) * pow(10, e)); +} + +sexp sexp_read_number(sexp ctx, sexp in, int base) { + sexp f, den; + sexp_uint_t res = 0, negativep = 0; + int c; + + c = sexp_read_char(ctx, in); + if (c == '-') + negativep = 1; + else if (isdigit(c)) + res = digit_value(c); + + if (base == 16) + for (c=sexp_read_char(ctx, in); isxdigit(c); c=sexp_read_char(ctx, in)) + res = res * base + digit_value(c); + else + for (c=sexp_read_char(ctx, in); isdigit(c); c=sexp_read_char(ctx, in)) + res = res * base + digit_value(c); + + if (c=='.' || c=='e' || c=='E') { + if (base != 10) + return + sexp_read_error(ctx, "decimal found in non-base 10", SEXP_NULL, in); + if (c!='.') + sexp_push_char(ctx, c, in); + f = sexp_read_float_tail(ctx, in, res); + if (! sexp_flonump(f)) return f; + if ((c!='.') && (sexp_flonum_value(f) == round(sexp_flonum_value(f)))) { + res = (sexp_sint_t) sexp_flonum_value(f); + } else { + if (negativep) +#if USE_IMMEDIATE_FLONUMS + f = sexp_make_flonum(ctx, -sexp_flonum_value(f)); +#else + sexp_flonum_value(f) = -sexp_flonum_value(f); +#endif + return f; + } + } else if (c=='/') { + den = sexp_read_number(ctx, in, base); + if (! sexp_integerp(den)) + return (sexp_exceptionp(den) + ? den : sexp_read_error(ctx, "invalid rational syntax", den, in)); + return sexp_make_flonum(ctx, (double)(negativep ? -res : res) + / (double)sexp_unbox_integer(den)); + } else { + if ((c!=EOF) && ! is_separator(c)) + return sexp_read_error(ctx, "invalid numeric syntax", + sexp_make_character(c), in); + sexp_push_char(ctx, c, in); + } + + return sexp_make_integer(negativep ? -res : res); +} + +sexp sexp_read_raw (sexp ctx, sexp in) { + char *str; + int c1, c2, line; + sexp tmp2; + sexp_gc_var(ctx, res, s_res); + sexp_gc_var(ctx, tmp, s_tmp); + sexp_gc_preserve(ctx, res, s_res); + sexp_gc_preserve(ctx, tmp, s_tmp); + + scan_loop: + switch (c1 = sexp_read_char(ctx, in)) { + case EOF: + res = SEXP_EOF; + break; + case ';': + while ((c1 = sexp_read_char(ctx, in)) != EOF) + if (c1 == '\n') + break; + /* ... FALLTHROUGH ... */ + case '\n': + sexp_port_line(in)++; + goto scan_loop; + case ' ': + case '\t': + case '\r': + goto scan_loop; + case '\'': + res = sexp_read(ctx, in); + res = sexp_list2(ctx, the_quote_symbol, res); + break; + case '`': + res = sexp_read(ctx, in); + res = sexp_list2(ctx, the_quasiquote_symbol, res); + break; + case ',': + if ((c1 = sexp_read_char(ctx, in)) == '@') { + res = sexp_read(ctx, in); + res = sexp_list2(ctx, the_unquote_splicing_symbol, res); + } else { + sexp_push_char(ctx, c1, in); + res = sexp_read(ctx, in); + res = sexp_list2(ctx, the_unquote_symbol, res); + } + break; + case '"': + res = sexp_read_string(ctx, in); + break; + case '(': + line = (sexp_port_sourcep(in) ? sexp_port_line(in) : -1); + res = SEXP_NULL; + tmp = sexp_read_raw(ctx, in); + while ((tmp != SEXP_EOF) && (tmp != SEXP_CLOSE) && (tmp != SEXP_RAWDOT)) { + res = sexp_cons(ctx, tmp, res); + tmp = sexp_read_raw(ctx, in); + if (sexp_exceptionp(tmp)) { + res = tmp; + break; + } + } + if (! sexp_exceptionp(res)) { + if (tmp == SEXP_RAWDOT) { /* dotted list */ + if (res == SEXP_NULL) { + res = sexp_read_error(ctx, "dot before any elements in list", + SEXP_NULL, in); + } else { + tmp = sexp_read_raw(ctx, in); + if (sexp_exceptionp(tmp)) { + res = tmp; + } else if (tmp == SEXP_CLOSE) { + res = sexp_read_error(ctx, "no final element in list after dot", + SEXP_NULL, in); + } else if (sexp_read_raw(ctx, in) != SEXP_CLOSE) { + res = sexp_read_error(ctx, "multiple tokens in dotted tail", + SEXP_NULL, in); + } else { + tmp2 = res; + res = sexp_nreverse(ctx, res); + sexp_cdr(tmp2) = tmp; + } + } + } else if (tmp == SEXP_CLOSE) { + res = (sexp_pairp(res) ? sexp_nreverse(ctx, res) : res); + } else { + res = sexp_read_error(ctx, "missing trailing ')'", SEXP_NULL, in); + } + } + if ((line >= 0) && sexp_pairp(res)) { + sexp_pair_source(res) + = sexp_cons(ctx, sexp_port_name(in), sexp_make_integer(line)); + } + if (sexp_port_sourcep(in)) + for (tmp=res; sexp_pairp(tmp); tmp=sexp_cdr(tmp)) + sexp_immutablep(tmp) = 1; + break; + case '#': + switch (c1=sexp_read_char(ctx, in)) { + case 'b': + res = sexp_read_number(ctx, in, 2); break; + case 'o': + res = sexp_read_number(ctx, in, 8); break; + case 'd': + res = sexp_read_number(ctx, in, 10); break; + case 'x': + res = sexp_read_number(ctx, in, 16); break; + case 'e': + res = sexp_read(ctx, in); + if (sexp_flonump(res)) + res = sexp_make_integer((sexp_sint_t)sexp_flonum_value(res)); + break; + case 'i': + res = sexp_read(ctx, in); + if (sexp_integerp(res)) + res = sexp_make_flonum(ctx, sexp_unbox_integer(res)); + break; + case 'f': + case 't': + c2 = sexp_read_char(ctx, in); + if (c2 == EOF || is_separator(c2)) { + res = (c1 == 't' ? SEXP_TRUE : SEXP_FALSE); + sexp_push_char(ctx, c2, in); + } else { + tmp = sexp_list2(ctx, sexp_make_character(c1), sexp_make_character(c2)); + res = sexp_read_error(ctx, "invalid syntax #%c%c", tmp, in); + } + break; +/* case '0': case '1': case '2': case '3': case '4': */ +/* case '5': case '6': case '7': case '8': case '9': */ + case ';': + tmp = sexp_read_raw(ctx, in); /* discard */ + if (sexp_exceptionp(tmp)) + res = tmp; + else + goto scan_loop; + case '\\': + c1 = sexp_read_char(ctx, in); + res = sexp_read_symbol(ctx, in, c1, 0); + if (sexp_stringp(res)) { + str = sexp_string_data(res); + if (sexp_string_length(res) == 0) + res = + sexp_read_error(ctx, "unexpected end of character literal", + SEXP_NULL, in); + if (sexp_string_length(res) == 1) { + res = sexp_make_character(c1); + } else if ((c1 == 'x' || c1 == 'X') && + isxdigit(str[1]) && isxdigit(str[2]) && str[3] == '\0') { + res = sexp_make_character(16 * digit_value(str[1]) + + digit_value(str[2])); + } else { + if (strcasecmp(str, "space") == 0) + res = sexp_make_character(' '); + else if (strcasecmp(str, "newline") == 0) + res = sexp_make_character('\n'); + else if (strcasecmp(str, "return") == 0) + res = sexp_make_character('\r'); + else if (strcasecmp(str, "tab") == 0) + res = sexp_make_character('\t'); + else { + tmp = sexp_c_string(ctx, str, -1); + res = sexp_read_error(ctx, "unknown character name", tmp, in); + } + } + } + break; + case '(': + sexp_push_char(ctx, c1, in); + res = sexp_read(ctx, in); + if (sexp_not(sexp_listp(ctx, res))) { + if (! sexp_exceptionp(res)) { + res = sexp_read_error(ctx, "dotted list not allowed in vector syntax", + SEXP_NULL, + in); + } + } else { + res = sexp_list_to_vector(ctx, res); + } + break; + default: + res = sexp_read_error(ctx, "invalid # syntax", + sexp_make_character(c1), in); + } + break; + case '.': + c1 = sexp_read_char(ctx, in); + if (c1 == EOF || is_separator(c1)) { + res = SEXP_RAWDOT; + } else if (isdigit(c1)) { + sexp_push_char(ctx, c1, in); + res = sexp_read_float_tail(ctx, in, 0); + } else { + sexp_push_char(ctx, c1, in); + res = sexp_read_symbol(ctx, in, '.', 1); + } + break; + case ')': + res = SEXP_CLOSE; + break; + case '+': + case '-': + c2 = sexp_read_char(ctx, in); + if (c2 == '.' || isdigit(c2)) { + sexp_push_char(ctx, c2, in); + res = sexp_read_number(ctx, in, 10); + if ((c1 == '-') && ! sexp_exceptionp(res)) { +#if USE_FLONUMS + if (sexp_flonump(res)) +#if USE_IMMEDIATE_FLONUMS + res = sexp_make_flonum(ctx, -1 * sexp_flonum_value(res)); +#else + sexp_flonum_value(res) = -1 * sexp_flonum_value(res); +#endif + else +#endif + res = sexp_fx_mul(res, -1); + } + } else { + sexp_push_char(ctx, c2, in); + res = sexp_read_symbol(ctx, in, c1, 1); + } + break; + case '0': case '1': case '2': case '3': case '4': + case '5': case '6': case '7': case '8': case '9': + sexp_push_char(ctx, c1, in); + res = sexp_read_number(ctx, in, 10); + break; + default: + res = sexp_read_symbol(ctx, in, c1, 1); + break; + } + + if (sexp_port_sourcep(in) && sexp_pointerp(res)) + sexp_immutablep(res) = 1; + sexp_gc_release(ctx, res, s_res); + return res; +} + +sexp sexp_read (sexp ctx, sexp in) { + sexp res = sexp_read_raw(ctx, in); + if (res == SEXP_CLOSE) + return sexp_read_error(ctx, "too many ')'s", SEXP_NULL, in); + if (res == SEXP_RAWDOT) + return sexp_read_error(ctx, "unexpected '.'", SEXP_NULL, in); + return res; +} + +sexp sexp_read_from_string(sexp ctx, char *str) { + sexp res; + sexp_gc_var(ctx, s, s_s); + sexp_gc_var(ctx, in, s_in); + sexp_gc_preserve(ctx, s, s_s); + sexp_gc_preserve(ctx, in, s_in); + s = sexp_c_string(ctx, str, -1); + in = sexp_make_input_string_port(ctx, s); + res = sexp_read(ctx, in); + sexp_gc_release(ctx, s, s_s); + return res; +} + +void sexp_init() { + int i; + sexp ctx; + if (! sexp_initialized_p) { + sexp_initialized_p = 1; +#if USE_BOEHM + GC_init(); + GC_add_roots((char*)&sexp_symbol_table, + ((char*)&sexp_symbol_table)+sizeof(sexp_symbol_table)+1); +#elif ! USE_MALLOC + sexp_gc_init(); +#endif + for (i=0; i 6 diff --git a/tests/basic/test00-fact-3.scm b/tests/basic/test00-fact-3.scm new file mode 100644 index 00000000..41d9c20e --- /dev/null +++ b/tests/basic/test00-fact-3.scm @@ -0,0 +1,14 @@ + +(define (fact-helper x res) + (if (= x 0) + res + (fact-helper (- x 1) (* res x)))) + +(define (fact x) + (fact-helper x 1)) + +(display "(fact 3) => ") +(write (fact 3)) +(newline) + + diff --git a/tests/basic/test01-apply.res b/tests/basic/test01-apply.res new file mode 100644 index 00000000..c5b83af4 --- /dev/null +++ b/tests/basic/test01-apply.res @@ -0,0 +1,8 @@ +11 +(11 10 9 8 7 6 5 4 3 2 1) +(1 2 3 4) +100 +100 +100 +100 +100 diff --git a/tests/basic/test01-apply.scm b/tests/basic/test01-apply.scm new file mode 100644 index 00000000..183a591c --- /dev/null +++ b/tests/basic/test01-apply.scm @@ -0,0 +1,18 @@ + +(define foo + (lambda (a b c d e f g h) + (+ (+ (* a b) (* c d)) (+ (* e f) (* g h))))) + +(define (writeln x) + (write x) + (newline)) + +(writeln (length (reverse (list 1 2 3 4 5 6 7 8 9 10 11)))) +(writeln (reverse (list 1 2 3 4 5 6 7 8 9 10 11))) +(writeln (append (list 1 2) (list 3 4))) +(writeln (foo 1 2 3 4 5 6 7 8)) +(writeln (apply foo (list 1 2 3 4 5 6 7 8))) +(writeln (apply foo 1 (list 2 3 4 5 6 7 8))) +(writeln (apply foo 1 2 3 4 (list 5 6 7 8))) +(writeln (apply foo 1 2 3 4 5 (list 6 7 8))) + diff --git a/tests/basic/test02-closure.res b/tests/basic/test02-closure.res new file mode 100644 index 00000000..4d764d20 --- /dev/null +++ b/tests/basic/test02-closure.res @@ -0,0 +1,6 @@ +1 +2 +101 +102 +3 +103 diff --git a/tests/basic/test02-closure.scm b/tests/basic/test02-closure.scm new file mode 100644 index 00000000..6ed987fe --- /dev/null +++ b/tests/basic/test02-closure.scm @@ -0,0 +1,16 @@ + +(define (make-counter n) + (lambda () + (set! n (+ n 1)) + n)) + +(define f (make-counter 0)) +(define g (make-counter 100)) + +(write (f)) (newline) +(write (f)) (newline) +(write (g)) (newline) +(write (g)) (newline) +(write (f)) (newline) +(write (g)) (newline) + diff --git a/tests/basic/test03-nested-closure.res b/tests/basic/test03-nested-closure.res new file mode 100644 index 00000000..c97c8394 --- /dev/null +++ b/tests/basic/test03-nested-closure.res @@ -0,0 +1 @@ +11357 diff --git a/tests/basic/test03-nested-closure.scm b/tests/basic/test03-nested-closure.scm new file mode 100644 index 00000000..6656bd4e --- /dev/null +++ b/tests/basic/test03-nested-closure.scm @@ -0,0 +1,8 @@ + +((lambda (a b) + ((lambda (c d e) + (write (+ e (* c 1000) (* a 100) (* b 10) d)) + (newline)) + (- a 2) (+ b 2) 10000)) + 3 5) + diff --git a/tests/basic/test04-nested-let.res b/tests/basic/test04-nested-let.res new file mode 100644 index 00000000..c97c8394 --- /dev/null +++ b/tests/basic/test04-nested-let.res @@ -0,0 +1 @@ +11357 diff --git a/tests/basic/test04-nested-let.scm b/tests/basic/test04-nested-let.scm new file mode 100644 index 00000000..584bc6e5 --- /dev/null +++ b/tests/basic/test04-nested-let.scm @@ -0,0 +1,9 @@ + +(let ((a 3) + (b 5)) + (let ((c (- a 2)) + (d (+ b 2)) + (e 10000)) + (write (+ e (* c 1000) (* a 100) (* b 10) d)) + (newline))) + diff --git a/tests/basic/test05-internal-define.res b/tests/basic/test05-internal-define.res new file mode 100644 index 00000000..4edae4cc --- /dev/null +++ b/tests/basic/test05-internal-define.res @@ -0,0 +1 @@ +1000 1003 diff --git a/tests/basic/test05-internal-define.scm b/tests/basic/test05-internal-define.scm new file mode 100644 index 00000000..a5576a63 --- /dev/null +++ b/tests/basic/test05-internal-define.scm @@ -0,0 +1,8 @@ + +(let ((a 1000)) + (define b (+ a 3)) + (write a) + (display " ") + (write b) + (newline)) + diff --git a/tests/basic/test06-letrec.res b/tests/basic/test06-letrec.res new file mode 100644 index 00000000..83d9c566 --- /dev/null +++ b/tests/basic/test06-letrec.res @@ -0,0 +1,4 @@ +7 +#t +#f +#f diff --git a/tests/basic/test06-letrec.scm b/tests/basic/test06-letrec.scm new file mode 100644 index 00000000..a9c01b4e --- /dev/null +++ b/tests/basic/test06-letrec.scm @@ -0,0 +1,15 @@ + +(letrec ((add (lambda (a b) (+ a b)))) + (write (add 3 4)) + (newline)) + +(letrec ((even? (lambda (n) (if (zero? n) #t (odd? (- n 1))))) + (odd? (lambda (n) (if (zero? n) #f (even? (- n 1)))))) + (write (even? 1000)) + (newline) + (write (even? 1001)) + (newline) + (write (odd? 1000)) + (newline) + ) + diff --git a/tests/basic/test07-mutation.res b/tests/basic/test07-mutation.res new file mode 100644 index 00000000..c97c8394 --- /dev/null +++ b/tests/basic/test07-mutation.res @@ -0,0 +1 @@ +11357 diff --git a/tests/basic/test07-mutation.scm b/tests/basic/test07-mutation.scm new file mode 100644 index 00000000..8dacb7fb --- /dev/null +++ b/tests/basic/test07-mutation.scm @@ -0,0 +1,9 @@ + +(let ((a 3) + (b 5)) + (let ((c (- a 2)) + (d (+ b 2)) + (e #f)) + (set! e 10000) + (write (+ e (* c 1000) (* a 100) (* b 10) d)) + (newline))) diff --git a/tests/basic/test08-callcc.res b/tests/basic/test08-callcc.res new file mode 100644 index 00000000..849baeed --- /dev/null +++ b/tests/basic/test08-callcc.res @@ -0,0 +1 @@ +543 diff --git a/tests/basic/test08-callcc.scm b/tests/basic/test08-callcc.scm new file mode 100644 index 00000000..3a5c355e --- /dev/null +++ b/tests/basic/test08-callcc.scm @@ -0,0 +1,34 @@ + +(define fail + (lambda () 999999)) + +(define in-range + (lambda (a b) + (call-with-current-continuation + (lambda (cont) + (enumerate a b cont))))) + +(define enumerate + (lambda (a b cont) + (if (< b a) + (fail) + (let ((save fail)) + (begin + (set! fail + (lambda () + (begin + (set! fail save) + (enumerate (+ a 1) b cont)))) + (cont a)))))) + +(write + (let ((x (in-range 2 9)) + (y (in-range 2 9)) + (z (in-range 2 9))) + (if (= (* x x) + (+ (* y y) (* z z))) + (+ (* x 100) (+ (* y 10) z)) + (fail)))) + +(newline) + diff --git a/tests/basic/test09-hygiene.res b/tests/basic/test09-hygiene.res new file mode 100644 index 00000000..31cd4d7e --- /dev/null +++ b/tests/basic/test09-hygiene.res @@ -0,0 +1,7 @@ +1 +2 +3 +4 +5 +6 +outer diff --git a/tests/basic/test09-hygiene.scm b/tests/basic/test09-hygiene.scm new file mode 100644 index 00000000..4ec53fe3 --- /dev/null +++ b/tests/basic/test09-hygiene.scm @@ -0,0 +1,62 @@ + +(write (or 1)) +(newline) +(write (or #f 2)) +(newline) +(write (or 3 #t)) +(newline) + +(let ((tmp 4)) + (write (or #f tmp)) + (newline)) + +(write + (letrec-syntax + ((myor + (er-macro-transformer + (lambda (expr rename compare) + (if (null? (cdr expr)) + #f + (list (rename 'let) (list (list (rename 'tmp) (cadr expr))) + (list (rename 'if) (rename 'tmp) + (rename 'tmp) + (cons (rename 'myor) (cddr expr))))))))) + (let ((tmp 5)) (myor #f tmp)))) +(newline) + +(define-syntax myor + (er-macro-transformer + (lambda (expr rename compare) + (if (null? (cdr expr)) + #f + (list (rename 'let) (list (list (rename 'tmp) (cadr expr))) + (list (rename 'if) (rename 'tmp) + (rename 'tmp) + (cons (rename 'myor) (cddr expr)))))))) + +(write (let ((tmp 6)) (myor #f tmp))) +(newline) + +;; (let ((x 'outer)) +;; (let-syntax ((with-x +;; (syntax-rules () +;; ((_ y expr) +;; (let-syntax ((y (syntax-rules () ((_) x)))) +;; expr))))) +;; (let ((x 'inner)) +;; (write (with-x z (z))) +;; (newline)))) + +(let ((x 'outer)) + (let-syntax ((with-x + (er-macro-transformer + (lambda (form rename compare) + `(let-syntax ((,(cadr form) + (er-macro-transformer + (lambda (form rename2 compare) + (rename2 'x))))) + ,(caddr form)))))) + (let ((x 'inner)) + (write (with-x z (z))) + (newline)))) + diff --git a/tests/basic/test10-unhygiene.res b/tests/basic/test10-unhygiene.res new file mode 100644 index 00000000..0d174dc4 --- /dev/null +++ b/tests/basic/test10-unhygiene.res @@ -0,0 +1,6 @@ +1 +1 +1 +6 +7 +8 diff --git a/tests/basic/test10-unhygiene.scm b/tests/basic/test10-unhygiene.scm new file mode 100644 index 00000000..c60a6bca --- /dev/null +++ b/tests/basic/test10-unhygiene.scm @@ -0,0 +1,49 @@ + +(define-syntax aif + (sc-macro-transformer + (lambda (form environment) + (let ((condition + (make-syntactic-closure environment '() (cadr form))) + (consequent + (make-syntactic-closure environment '(it) (caddr form))) + (alternative + (make-syntactic-closure environment '() (cadddr form)))) + `(let ((it ,condition)) + (if it + ,consequent + ,alternative)))))) + +(write (aif 1 it 3)) +(newline) + +(write (let ((it 4)) (aif 1 it 3))) +(newline) + +(write (let ((it 4)) (aif (let ((it 5)) 1) it 3))) +(newline) + +(write (let ((it 4)) (aif (let ((it 5)) 1) (let ((it 6)) it) 3))) +(newline) + +(write + (letrec-syntax + ((myor + (er-macro-transformer + (lambda (expr rename compare) + (if (null? (cdr expr)) + #f + (list (rename 'let) (list (list (rename 'it) (cadr expr))) + (list (rename 'if) (rename 'it) + (rename 'it) + (cons (rename 'myor) (cddr expr))))))))) + (let ((it 7)) (myor #f it)))) +(newline) + +(define-syntax define-foo + (sc-macro-transformer + (lambda (form environment) + (make-syntactic-closure environment '(foo) `(define foo 8))))) + +(define-foo) +(write foo) +(newline) diff --git a/tests/r5rs-tests.scm b/tests/r5rs-tests.scm new file mode 100644 index 00000000..8fc0606e --- /dev/null +++ b/tests/r5rs-tests.scm @@ -0,0 +1,377 @@ + +(define *tests-run* 0) +(define *tests-passed* 0) + +(define-syntax test + (syntax-rules () + ((test expect expr) + (begin + (set! *tests-run* (+ *tests-run* 1)) + (let ((str (call-with-output-string (lambda (out) (display 'expr out)))) + (res expr)) + (display str) + (write-char #\space) + (display (make-string (max 0 (- 72 (string-length str))) #\.)) + (flush-output) + (cond + ((equal? res expect) + (set! *tests-passed* (+ *tests-passed* 1)) + (display " [PASS]\n")) + (else + (display " [FAIL]\n") + (display " expected ") (write expect) + (display " but got ") (write res) (newline)))))))) + +(define (test-report) + (write *tests-passed*) + (display " out of ") + (write *tests-run*) + (display " passed (") + (write (* (/ *tests-passed* *tests-run*) 100)) + (display "%)") + (newline)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(test 8 ((lambda (x) (+ x x)) 4)) + +(test '(3 4 5 6) ((lambda x x) 3 4 5 6)) + +(test '(5 6) ((lambda (x y . z) z) 3 4 5 6)) + +(test 'yes (if (> 3 2) 'yes 'no)) + +(test 'no (if (> 2 3) 'yes 'no)) + +(test 1 (if (> 3 2) (- 3 2) (+ 3 2))) + +(test 'greater (cond ((> 3 2) 'greater) ((< 3 2) 'less))) + +(test 'equal (cond ((> 3 3) 'greater) ((< 3 3) 'less) (else 'equal))) + +(test 'composite (case (* 2 3) ((2 3 5 7) 'prime) ((1 4 6 8 9) 'composite))) + +(test 'consonant + (case (car '(c d)) + ((a e i o u) 'vowel) + ((w y) 'semivowel) + (else 'consonant))) + +(test #t (and (= 2 2) (> 2 1))) + +(test #f (and (= 2 2) (< 2 1))) + +(test '(f g) (and 1 2 'c '(f g))) + +(test #t (and)) + +(test #t (or (= 2 2) (> 2 1))) + +(test #t (or (= 2 2) (< 2 1))) + +(test '(b c) (or (memq 'b '(a b c)) (/ 3 0))) + +(test 6 (let ((x 2) (y 3)) (* x y))) + +(test 35 (let ((x 2) (y 3)) (let ((x 7) (z (+ x y))) (* z x)))) + +(test 70 (let ((x 2) (y 3)) (let* ((x 7) (z (+ x y))) (* z x)))) + +(test '#(0 1 2 3 4) + (do ((vec (make-vector 5)) + (i 0 (+ i 1))) + ((= i 5) vec) + (vector-set! vec i i))) + +(test 25 + (let ((x '(1 3 5 7 9))) + (do ((x x (cdr x)) + (sum 0 (+ sum (car x)))) + ((null? x) + sum)))) + +(test '((6 1 3) (-5 -2)) + (let loop ((numbers '(3 -2 1 6 -5)) (nonneg '()) (neg '())) + (cond + ((null? numbers) + (list nonneg neg)) + ((>= (car numbers) 0) + (loop (cdr numbers) (cons (car numbers) nonneg) neg)) + ((< (car numbers) 0) + (loop (cdr numbers) nonneg (cons (car numbers) neg)))))) + +(test '(list 3 4) `(list ,(+ 1 2) 4)) + +(test '(list a 'a) (let ((name 'a)) `(list ,name ',name))) + +(test '(a 3 4 5 6 b) + `(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b)) + +(test '(10 5 2 4 3 8) + `(10 5 ,(sqrt 4) ,@(map sqrt '(16 9)) 8)) + +(test '(a `(b ,(+ 1 2) ,(foo 4 d) e) f) + `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f)) + +(test '(a `(b ,x ,'y d) e) + (let ((name1 'x) + (name2 'y)) + `(a `(b ,,name1 ,',name2 d) e))) + +(test '(list 3 4) + (quasiquote (list (unquote (+ 1 2)) 4))) + +(test #t (eqv? 'a 'a)) + +(test #f (eqv? 'a 'b)) + +(test #t (eqv? '() '())) + +(test #f (eqv? (cons 1 2) (cons 1 2))) + +(test #f (eqv? (lambda () 1) (lambda () 2))) + +(test #t (let ((p (lambda (x) x))) (eqv? p p))) + +(test #t (eq? 'a 'a)) + +(test #f (eq? (list 'a) (list 'a))) + +(test #t (eq? '() '())) + +(test #t (eq? car car)) + +(test #t (let ((x '(a))) (eq? x x))) + +(test #t (let ((p (lambda (x) x))) (eq? p p))) + +(test #t (equal? 'a 'a)) + +(test #t (equal? '(a) '(a))) + +(test #t (equal? '(a (b) c) '(a (b) c))) + +(test #t (equal? "abc" "abc")) + +(test #t (equal? 2 2)) + +(test #t (equal? (make-vector 5 'a) (make-vector 5 'a))) + +(test 4 (max 3 4)) + +(test 4 (max 3.9 4)) + +(test 7 (+ 3 4)) + +(test 3 (+ 3)) + +(test 0 (+)) + +(test 4 (* 4)) + +(test 1 (*)) + +(test -1 (- 3 4)) + +(test -6 (- 3 4 5)) + +(test -3 (- 3)) + +(test 7 (abs -7)) + +(test 1 (modulo 13 4)) + +(test 1 (remainder 13 4)) + +(test 3 (modulo -13 4)) + +(test -1 (remainder -13 4)) + +(test -3 (modulo 13 -4)) + +(test 1 (remainder 13 -4)) + +(test -1 (modulo -13 -4)) + +(test -1 (remainder -13 -4)) + +(test 4 (gcd 32 -36)) + +(test 288 (lcm 32 -36)) + +(test -5 (floor -4.3)) + +(test -4 (ceiling -4.3)) + +(test -4 (truncate -4.3)) + +(test -4 (round -4.3)) + +(test 3 (floor 3.5)) + +(test 4 (ceiling 3.5)) + +(test 3 (truncate 3.5)) + +(test 4 (round 3.5)) + +(test 100 (string->number "100")) + +(test 256 (string->number "100" 16)) + +(test 100 (string->number "1e2")) + +(test #f (not 3)) + +(test #f (not (list 3))) + +(test #f (not '())) + +(test #f (not (list))) + +(test #f (not '())) + +(test #f (boolean? 0)) + +(test #f (boolean? '())) + +(test #t (pair? '(a . b))) + +(test #t (pair? '(a b c))) + +(test '(a) (cons 'a '())) + +(test '((a) b c d) (cons '(a) '(b c d))) + +(test '("a" b c) (cons "a" '(b c))) + +(test '(a . 3) (cons 'a 3)) + +(test '((a b) . c) (cons '(a b) 'c)) + +(test 'a (car '(a b c))) + +(test '(a) (car '((a) b c d))) + +(test 1 (car '(1 . 2))) + +(test '(b c d) (cdr '((a) b c d))) + +(test 2 (cdr '(1 . 2))) + +(test #t (list? '(a b c))) + +(test #t (list? '())) + +(test #f (list? '(a . b))) + +(test #f + (let ((x (list 'a))) + (set-cdr! x x) + (list? x))) + +(test '(a 7 c) (list 'a (+ 3 4) 'c)) + +(test '() (list)) + +(test 3 (length '(a b c))) + +(test 3 (length '(a (b) (c d e)))) + +(test 0 (length '())) + +(test '(x y) (append '(x) '(y))) + +(test '(a b c d) (append '(a) '(b c d))) + +(test '(a (b) (c)) (append '(a (b)) '((c)))) + +(test '(a b c . d) (append '(a b) '(c . d))) + +(test 'a (append '() 'a)) + +(test '(c b a) (reverse '(a b c))) + +(test '((e (f)) d (b c) a) (reverse '(a (b c) d (e (f))))) + +(test 'c (list-ref '(a b c d) 2)) + +(test '(a b c) (memq 'a '(a b c))) + +(test '(b c) (memq 'b '(a b c))) + +(test #f (memq 'a '(b c d))) + +(test #f (memq (list 'a) '(b (a) c))) + +(test '((a) c) (member (list 'a) '(b (a) c))) + +(test '(101 102) (memv 101 '(100 101 102))) + +(test #f (assq (list 'a) '(((a)) ((b)) ((c))))) + +(test '((a)) (assoc (list 'a) '(((a)) ((b)) ((c))))) + +(test '(5 7) (assv 5 '((2 3) (5 7) (11 13)))) + +(test #t (symbol? 'foo)) + +(test #t (symbol? (car '(a b)))) + +(test #f (symbol? "bar")) + +(test #t (symbol? 'nil)) + +(test #f (symbol? '())) + +(test "flying-fish" (symbol->string 'flying-fish)) + +(test "Martin" (symbol->string 'Martin)) + +(test "Malvina" (symbol->string (string->symbol "Malvina"))) + +(test '#(0 ("Sue" "Sue") "Anna") + (let ((vec (vector 0 '(2 2 2 2) "Anna"))) + (vector-set! vec 1 '("Sue" "Sue")) + vec)) + +(test '(dah dah didah) (vector->list '#(dah dah didah))) + +(test '#(dididit dah) (list->vector '(dididit dah))) + +(test #t (procedure? car)) + +(test #f (procedure? 'car)) + +(test #t (procedure? (lambda (x) (* x x)))) + +(test #f (procedure? '(lambda (x) (* x x)))) + +(test #t (call-with-current-continuation procedure?)) + +(test 7 (apply + (list 3 4))) + +(test '(b e h) (map cadr '((a b) (d e) (g h)))) + +(test '(1 4 27 256 3125) (map (lambda (n) (expt n n)) '(1 2 3 4 5))) + +(test '(5 7 9) (map + '(1 2 3) '(4 5 6))) + +(test '#(0 1 4 9 16) + (let ((v (make-vector 5))) + (for-each + (lambda (i) (vector-set! v i (* i i))) + '(0 1 2 3 4)) + v)) + +(test 3 (force (delay (+ 1 2)))) + +(test '(3 3) (let ((p (delay (+ 1 2)))) (list (force p) (force p)))) + +(test 7 (call-with-current-continuation (lambda (k) (+ 2 5)))) + +(test 3 (call-with-current-continuation (lambda (k) (+ 2 5 (k 3))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(test-report) From bf598f6ee5948e33970ff40238f684383ea86572 Mon Sep 17 00:00:00 2001 From: felix Date: Tue, 30 Jun 2009 09:50:32 +0200 Subject: [PATCH 153/154] basic mingw support --- Makefile | 17 ++++++--- include/chibi/config.h | 8 ++++ include/chibi/eval.h | 14 +++---- include/chibi/sexp.h | 84 +++++++++++++++++++++--------------------- 4 files changed, 69 insertions(+), 54 deletions(-) diff --git a/Makefile b/Makefile index 84d97ed4..ed68da76 100644 --- a/Makefile +++ b/Makefile @@ -2,8 +2,6 @@ .PHONY: all doc dist clean cleaner test install uninstall -all: chibi-scheme - CC ?= cc PREFIX ?= /usr/local BINDIR ?= $(PREFIX)/bin @@ -15,9 +13,13 @@ ifndef PLATFORM ifeq ($(shell uname),Darwin) PLATFORM=macosx else +ifeq ($(shell uname -o),Msys) +PLATFORM=mingw +else PLATFORM=unix endif endif +endif ifeq ($(PLATFORM),macosx) SO = .dylib @@ -28,7 +30,10 @@ else ifeq ($(PLATFORM),mingw) SO = .dll EXE = .exe -CLIBFLAGS = -fPIC -shared +CC = gcc +CLIBFLAGS = -shared +CPPFLAGS += -DUSE_STRING_STREAMS=0 -DBUILDING_DLL -DUSE_DEBUG=0 +LDFLAGS += -Wl,--out-implib,libchibi-scheme$(SO).a else SO = .so EXE = @@ -37,6 +42,8 @@ STATICFLAGS = -static endif endif +all: chibi-scheme$(EXE) + ifdef USE_BOEHM GCLDFLAGS := -lgc XCPPFLAGS := $(CPPFLAGS) -Iinclude -DUSE_BOEHM=1 @@ -75,10 +82,10 @@ clean: rm -f *.o *.i *.s cleaner: clean - rm -f chibi-scheme chibi-scheme-static *$(SO) + rm -f chibi-scheme$(EXE) chibi-scheme-static$(EXE) *$(SO) *.a rm -rf *.dSYM -test-basic: chibi-scheme +test-basic: chibi-scheme$(EXE) @for f in tests/basic/*.scm; do \ ./chibi-scheme $$f >$${f%.scm}.out 2>$${f%.scm}.err; \ if diff -q $${f%.scm}.out $${f%.scm}.res; then \ diff --git a/include/chibi/config.h b/include/chibi/config.h index e3fdf9b6..57556c2f 100644 --- a/include/chibi/config.h +++ b/include/chibi/config.h @@ -118,3 +118,11 @@ #endif #endif + +#ifdef __MINGW32__ +#ifdef BUILDING_DLL +#define DLLEXPORT __declspec(dllexport) +#else +#define DLLEXPORT __declspec(dllimport) +#endif +#endif diff --git a/include/chibi/eval.h b/include/chibi/eval.h index 1b51c8f5..9847952a 100644 --- a/include/chibi/eval.h +++ b/include/chibi/eval.h @@ -128,13 +128,13 @@ enum opcode_names { /**************************** prototypes ******************************/ -void sexp_scheme_init(); -sexp sexp_apply(sexp context, sexp proc, sexp args); -sexp sexp_eval(sexp context, sexp obj); -sexp sexp_eval_string(sexp context, char *str); -sexp sexp_load(sexp context, sexp expr, sexp env); -sexp sexp_make_context(sexp context, sexp stack, sexp env); -void sexp_warn_undefs(sexp ctx, sexp from, sexp to, sexp out); +DLLEXPORT void sexp_scheme_init(); +DLLEXPORT sexp sexp_apply(sexp context, sexp proc, sexp args); +DLLEXPORT sexp sexp_eval(sexp context, sexp obj); +DLLEXPORT sexp sexp_eval_string(sexp context, char *str); +DLLEXPORT sexp sexp_load(sexp context, sexp expr, sexp env); +DLLEXPORT sexp sexp_make_context(sexp context, sexp stack, sexp env); +DLLEXPORT void sexp_warn_undefs(sexp ctx, sexp from, sexp to, sexp out); #endif /* ! SEXP_EVAL_H */ diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index d1538cf2..6cc51fe2 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -539,53 +539,53 @@ sexp sexp_make_flonum(sexp ctx, double f); #define sexp_write_string(x, s, p) (sexp_port_buf(p) ? sexp_buffered_write_string(x, s, p) : (fputs(s, sexp_port_stream(p)), SEXP_VOID)) #define sexp_flush(x, p) (sexp_port_buf(p) ? sexp_buffered_flush(x, p) : (fflush(sexp_port_stream(p)), SEXP_VOID)) -int sexp_buffered_read_char (sexp ctx, sexp p); -sexp sexp_buffered_write_char (sexp ctx, int c, sexp p); -sexp sexp_buffered_write_string_n (sexp ctx, char *str, sexp_uint_t len, sexp p); -sexp sexp_buffered_write_string (sexp ctx, char *str, sexp p); -sexp sexp_buffered_flush (sexp ctx, sexp p); +DLLEXPORT int sexp_buffered_read_char (sexp ctx, sexp p); +DLLEXPORT sexp sexp_buffered_write_char (sexp ctx, int c, sexp p); +DLLEXPORT sexp sexp_buffered_write_string_n (sexp ctx, char *str, sexp_uint_t len, sexp p); +DLLEXPORT sexp sexp_buffered_write_string (sexp ctx, char *str, sexp p); +DLLEXPORT sexp sexp_buffered_flush (sexp ctx, sexp p); #endif #define sexp_newline(ctx, p) sexp_write_char(ctx, '\n', (p)) -sexp sexp_alloc_tagged(sexp ctx, size_t size, sexp_uint_t tag); -sexp sexp_cons(sexp ctx, sexp head, sexp tail); -sexp sexp_list2(sexp ctx, sexp a, sexp b); -sexp sexp_equalp (sexp ctx, sexp a, sexp b); -sexp sexp_listp(sexp ctx, sexp obj); -sexp sexp_reverse(sexp ctx, sexp ls); -sexp sexp_nreverse(sexp ctx, sexp ls); -sexp sexp_append2(sexp ctx, sexp a, sexp b); -sexp sexp_memq(sexp ctx, sexp x, sexp ls); -sexp sexp_assq(sexp ctx, sexp x, sexp ls); -sexp sexp_length(sexp ctx, sexp ls); -sexp sexp_c_string(sexp ctx, char *str, sexp_sint_t slen); -sexp sexp_make_string(sexp ctx, sexp len, sexp ch); -sexp sexp_substring (sexp ctx, sexp str, sexp start, sexp end); -sexp sexp_string_concatenate (sexp ctx, sexp str_ls); -sexp sexp_intern(sexp ctx, char *str); -sexp sexp_string_to_symbol(sexp ctx, sexp str); -sexp sexp_make_vector(sexp ctx, sexp len, sexp dflt); -sexp sexp_list_to_vector(sexp ctx, sexp ls); -void sexp_write(sexp ctx, sexp obj, sexp out); -sexp sexp_read_string(sexp ctx, sexp in); -sexp sexp_read_symbol(sexp ctx, sexp in, int init, int internp); -sexp sexp_read_number(sexp ctx, sexp in, int base); -sexp sexp_read_raw(sexp ctx, sexp in); -sexp sexp_read(sexp ctx, sexp in); -sexp sexp_read_from_string(sexp ctx, char *str); -sexp sexp_make_input_port(sexp ctx, FILE* in, sexp name); -sexp sexp_make_output_port(sexp ctx, FILE* out, sexp name); -sexp sexp_make_input_string_port(sexp ctx, sexp str); -sexp sexp_make_output_string_port(sexp ctx); -sexp sexp_get_output_string(sexp ctx, sexp port); -sexp sexp_make_exception(sexp ctx, sexp kind, sexp message, sexp irritants, sexp procedure, sexp source); -sexp sexp_user_exception (sexp ctx, sexp self, char *message, sexp obj); -sexp sexp_type_exception (sexp ctx, char *message, sexp obj); -sexp sexp_range_exception (sexp ctx, sexp obj, sexp start, sexp end); -sexp sexp_print_exception(sexp ctx, sexp exn, sexp out); -void sexp_init(); +DLLEXPORT sexp sexp_alloc_tagged(sexp ctx, size_t size, sexp_uint_t tag); +DLLEXPORT sexp sexp_cons(sexp ctx, sexp head, sexp tail); +DLLEXPORT sexp sexp_list2(sexp ctx, sexp a, sexp b); +DLLEXPORT sexp sexp_equalp (sexp ctx, sexp a, sexp b); +DLLEXPORT sexp sexp_listp(sexp ctx, sexp obj); +DLLEXPORT sexp sexp_reverse(sexp ctx, sexp ls); +DLLEXPORT sexp sexp_nreverse(sexp ctx, sexp ls); +DLLEXPORT sexp sexp_append2(sexp ctx, sexp a, sexp b); +DLLEXPORT sexp sexp_memq(sexp ctx, sexp x, sexp ls); +DLLEXPORT sexp sexp_assq(sexp ctx, sexp x, sexp ls); +DLLEXPORT sexp sexp_length(sexp ctx, sexp ls); +DLLEXPORT sexp sexp_c_string(sexp ctx, char *str, sexp_sint_t slen); +DLLEXPORT sexp sexp_make_string(sexp ctx, sexp len, sexp ch); +DLLEXPORT sexp sexp_substring (sexp ctx, sexp str, sexp start, sexp end); +DLLEXPORT sexp sexp_string_concatenate (sexp ctx, sexp str_ls); +DLLEXPORT sexp sexp_intern(sexp ctx, char *str); +DLLEXPORT sexp sexp_string_to_symbol(sexp ctx, sexp str); +DLLEXPORT sexp sexp_make_vector(sexp ctx, sexp len, sexp dflt); +DLLEXPORT sexp sexp_list_to_vector(sexp ctx, sexp ls); +DLLEXPORT void sexp_write(sexp ctx, sexp obj, sexp out); +DLLEXPORT sexp sexp_read_string(sexp ctx, sexp in); +DLLEXPORT sexp sexp_read_symbol(sexp ctx, sexp in, int init, int internp); +DLLEXPORT sexp sexp_read_number(sexp ctx, sexp in, int base); +DLLEXPORT sexp sexp_read_raw(sexp ctx, sexp in); +DLLEXPORT sexp sexp_read(sexp ctx, sexp in); +DLLEXPORT sexp sexp_read_from_string(sexp ctx, char *str); +DLLEXPORT sexp sexp_make_input_port(sexp ctx, FILE* in, sexp name); +DLLEXPORT sexp sexp_make_output_port(sexp ctx, FILE* out, sexp name); +DLLEXPORT sexp sexp_make_input_string_port(sexp ctx, sexp str); +DLLEXPORT sexp sexp_make_output_string_port(sexp ctx); +DLLEXPORT sexp sexp_get_output_string(sexp ctx, sexp port); +DLLEXPORT sexp sexp_make_exception(sexp ctx, sexp kind, sexp message, sexp irritants, sexp procedure, sexp source); +DLLEXPORT sexp sexp_user_exception (sexp ctx, sexp self, char *message, sexp obj); +DLLEXPORT sexp sexp_type_exception (sexp ctx, char *message, sexp obj); +DLLEXPORT sexp sexp_range_exception (sexp ctx, sexp obj, sexp start, sexp end); +DLLEXPORT sexp sexp_print_exception(sexp ctx, sexp exn, sexp out); +DLLEXPORT void sexp_init(); #endif /* ! SEXP_H */ From cf9ec69fd3199de874b5d56098c2e27930154163 Mon Sep 17 00:00:00 2001 From: felix Date: Tue, 30 Jun 2009 09:54:28 +0200 Subject: [PATCH 154/154] more mingw fixes in Makefile --- Makefile | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/Makefile b/Makefile index ed68da76..fbc0e84b 100644 --- a/Makefile +++ b/Makefile @@ -6,6 +6,7 @@ CC ?= cc PREFIX ?= /usr/local BINDIR ?= $(PREFIX)/bin LIBDIR ?= $(PREFIX)/lib +SOLIBDIR ?= $(PREFIX)/lib INCDIR ?= $(PREFIX)/include/chibi MODDIR ?= $(PREFIX)/share/chibi @@ -15,6 +16,7 @@ PLATFORM=macosx else ifeq ($(shell uname -o),Msys) PLATFORM=mingw +SOLIBDIR = $(BINDIR) else PLATFORM=unix endif @@ -98,7 +100,7 @@ test-basic: chibi-scheme$(EXE) test: chibi-scheme ./chibi-scheme tests/r5rs-tests.scm -install: chibi-scheme +install: chibi-scheme$(EXE) mkdir -p $(BINDIR) cp chibi-scheme $(BINDIR)/ mkdir -p $(MODDIR) @@ -106,12 +108,14 @@ install: chibi-scheme mkdir -p $(INCDIR) cp $(INCLUDES) include/chibi/eval.h $(INCDIR)/ mkdir -p $(LIBDIR) - cp libchibi-scheme$(SO) $(LIBDIR)/ + cp libchibi-scheme$(SO) $(SOLIBDIR)/ + -cp libchibi-scheme$(SO).a $(LIBDIR)/ if type ldconfig >/dev/null 2>/dev/null; then ldconfig; fi uninstall: rm -f $(BINDIR)/chibi-scheme* - rm -f $(LIBDIR)/libchibi-scheme$(SO) + rm -f $(SOLIBDIR)/libchibi-scheme$(SO) + rm -f $(LIBDIR)/libchibi-scheme$(SO).a cd $(INCDIR) && rm -f $(INCLUDES) include/chibi/eval.h rm -f $(MODDIR)/*.scm